00100			SUBTTL AC DEFINITIONS AND EXTERNALS 		--- PAGE 1
00200	TITLE ILISP INTERPRETER
00300	TWOSEG
00400	;SYSPRG==667	;PPN OF LISP SYSTEM - SET TO 0 FOR SYS:
00500	;SYSPN==2	;SAME HERE
00600	IFNDEF SYSPRG,<SYSPRG==0
00700		       SYSPN==0>
00800	;ALVINE==1		;1 FOR ALVINE, 0 FOR NO ALVINE
00900	IFNDEF ALVINE,<ALVINE==0>
01000	;HASH==1		;1 FOR SETTING # OF HASH BUCKETS AT SYS. INIT. TIME
01100	IFNDEF HASH,<HASH==0>
01200	;STPGAP==1		;1 FOR STOPGAP, 0 TO DELETE IT
01300	IFNDEF STPGAP,<STPGAP==0>
01400	IF1,<PURGE CDR,DF>
01410	STANSW==1		;1 FOR STANFORD, 0 FOR CHRISTIANS
01420	IFNDEF STANSW,<STANSW==0>
01430	
01500	MLON
01600	INUMIN=377777
01700	INUM0=<INUMIN+777777>/2
01800	BCKETS==177
01900	IFE SYSPRG,<DEFINE SYSDEV <SIXBIT /SYS/>>
02000	IFN SYSPRG,<DEFINE SYSDEV <SIXBIT /DSK/>>
02100	DEFINE SYSNAM <SIXBIT /ILISP1/>				;	*** MJC
02200	
02300	;accumulator definitions
02400	;`sacred' means sacred to the interpreter
02500	;`marked' means marked from by the garbage collector
02600	;`protected' means protected during garbage collection
02700	
02800	NIL=0	;sacred, marked, protected	;atom head of NIL
02900	A=1	;marked, protected	;results of functions and first arg of subrs
03000	B=A+1	;marked, protected	;second arg of subrs
03100		C=B+1	;marked, protected	;third arg of subrs
03200	AR1=4	;marked, protected	;fourth arg of subrs
03300	AR2A=5	;marked, protected	;fifth arg of subrs
03400	T=6	;marked, protected	;minus number of args in LSUBR call
03500	TT=7	;marked, protected
03600	REL=10	;marked, protected	
03700	S=11		;$$NOW USED FOR ATOM RELOCATION AND GARBAGE COLLECTOR
03800	D=12	
03900	R=13	;protected
04000	P=14	;sacred, protected	;regular push down stack pointer
04100	F=15	;sacred	;free storage list pointer
04200	FF=16	;sacred	;full word list pointer
04300	SP=17	;sacred, protected	;special pushdown stack pointer
04400	
04500	NACS==5	;number of argument acs
04600	
04700	X==0	;X indicates impure (modified) code locations
04800	TEN==↑D10
04900	
05000	;UUO definitions
05100	;UUOs used to call functions from compiled code
05200	;the number of arguments is given by the ac field 
05300	;the address is a pointer either to the function 
05400	;name or the code of the function
05500	OPDEF FCALL [34B8]	;ordinary function call-may be changed to PUSHJ
05600	OPDEF JCALL [35B8]	;terminal function call-may be changed to JRST
05700	OPDEF CALLF [36B8]	;like call but may not be changed to PUSHJ
05800	OPDEF JCALLF [37B8]	;like jcall but may not be changed to JRST
05900	;error UUOs 
06000	
06100	OPDEF ERR1 [1B8]	;ordinary lisp error	;gives backtrace
06200	OPDEF ERR2 [2B8]	;space overflow error	;no backtrace
06300	OPDEF ERR3 [3B8]	;ill. mem. ref.
06400	OPDEF STRTIP [4B8]	;print error message and continue
06500	;system UUOs
06600	
06700	OPDEF TTYUUO [51B8]
06800	OPDEF INCHRW [TTYUUO 0,]
06900	OPDEF OUTCHR [TTYUUO 1,]
07000	OPDEF OUTSTR [TTYUUO 3,]
07100	OPDEF INCHWL [TTYUUO 4,]
07200	OPDEF INCHSL [TTYUUO 5,]
07300	OPDEF CLRBFI [TTYUUO 11,]
07400	OPDEF SKPINC [TTYUUO 13,]
07500	OPDEF TALK [PUSHJ P,TTYCLR]	;this is to turn off control O.
07600					;when ttyser lets you do this
07700					;easily, change me
07800	
07900	;I/O bits and constants
08000	TTYLL==105	;teletype linelength 
08100	LPTLL==160	;line printer linelength
08200	MLIOB==203	;max length of I/O buffer
08300	NIOB==2	;no of I/O buffers per device
08400	NIOCH==17	;number of I/O channels
08500	FSTCH==1	;first I/O channel
08600	TTCH==0		;teletype I/O channel
08700	BLKSIZE==NIOB*MLIOB+COUNT+1
08800	INB==2
08900	OUTB==1
09000	AVLB==40
09100	DIRB==4
09200	
09300	;special ASCII characters
09400	ALTMOD==175
09500	SPACE==40	;space
09600	IGCRLF==31	;ignored cr-lf
09700	RUBOUT==177
09800	LF==12
09900	CR==15
10000	TAB==11
10100	BELL==7
10200	DBLQT==42	;double quote "
10300	
10400	;byte pointer field definitions
10500	ACFLD==14	;ac field
10600	XFLD==21	;index field
10700	OPFLD==10	;opcode field
10800	ADRFLD==43	;adress field
10900	
11000	;external and internal symbols
11100	
11200	EXTERNAL JOB41	;instruction to be executed on UUO
11300	EXTERNAL JOBAPR	;address of APR interupt routines
11400	EXTERNAL JOBCNI	;interupt condition flags
11500	EXTERNAL JOBFF	;first location beyond program
11600	EXTERNAL JOBREL	;address of last legal instruction in core image
11700	EXTERNAL JOBREN	;reentry address
11800	EXTERNAL JOBSA	;starting address
11900	EXTERNAL JOBSYM	;address of symbol table
12000	EXTERNAL JOBTPC	;program counter at time of interupt
12100	EXTERNAL JOBUUO	;uuo is put here with effective address computed
12200	EXTERNAL JOBOPC ;$$FOR NEW REENTER FEATURES
12300	EXTERNAL JOBHRL ;HIGH SEGMENT BOUNDARY
12400	
12500	
12600	;apr flags
12700	PDOV==200000	;push down list overflow
12800	MPV==20000	;memory protection violation
12900	NXM==10000	;non-existant memory referenced
13000	APRFLG==PDOV+MPV+NXM	;any of the above
13100	
13200	;RE-ENTER CONTROL CHARACTERS
13300	CNTLH==10
13400	CNTLE==5
13500	CNTLB==2
13600	CNTLZ==32
13700	CNTLG==7
13800	
13900	;system uuos
14000	APRINI==16
14100	RESET==0
14200	STIME==27
14300	DEVCHR==4
14400	EXIT==12
14500	CORE==11
14600	SETUWP==36
14700	GETSEG==40
14800	;REMOTE MACRO
14900	
15000		DEFINE REMOTE (TX)
15100	<	HERE1 <TX>>
15200	
15300		DEFINE HERE1 (NEW,OLD,%G)
15400	<	DEFINE %G
15500	<	NEW>
15600		DEFINE REMOTE (TX)
15700	<	HERE1 <TX>,<OLD
15800	%G
15900	>>>
16000		DEFINE HERE
16100	<	DEFINE HERE1 (XX,YY)
16200	<	YY>
16300		REMOTE>
16400	SALL
16500			SUBTTL TOP LEVEL AND INITIALIZATION  --- PAGE 2
16600	PAGE
16700	
16800	SHRST==400000
16900		RELOC	SHRST
17000	REMOTE<
17100	LISPGO:	SKIPE	GCFLG	;$$CHECK FO GARBAGE COLLECTION
17200		PUSHJ	P,GCING	;$$QUEUE THE REQUEST
17300	;	CAME	0,STNIL	;$$UNBIND STACK IF REGS LOOK OK		*** MJC
17400	;	JRST	GETHGH	;GO GET HIGH SEGMENT			*** MJC
17500	;	MOVE	B,SC2						*** MJC
17600	;	PUSHJ	P,UBD	;$$UNBIND STACK				*** MJC
17700	;	JRST STRT	;go to re-allocator			*** MJC
17800	;GETHGH:	CALLI	RESET					*** MJC
17900	;	MOVSI	A,1						*** MJC
18000	;IFE STANSW,<	CALLI	A,CORE	;ELIMINATE ANY OLD HIGH SEGS.	*** MJC
18005	;	HALT >							*** MJC
18010	;***   IFN STANSW,<	CALLI A,400015
18055	;***	HALT>
18200	;***	MOVEI	A,HGHDAT
18300	;***	CALLI	A,GETSEG	;GET THE PROPER HIGH SEG
18400	;***	HALT
18402	       	MOVE	A,HGHDAT+1	; Get high segment name		*** MJC
18406		CALLI	A,400016	; Attach to high seg if poss.	*** MJC
18408		CAIN	A,4	; If err=4 (seg alrdy there) ok too	*** MJC
18410		JRST	STRT		; Success!			*** MJC
18414	
18418		CALLI	400017		; Detach stray segments.	*** MJC
18419		MOVE	A,HGHDAT	; Get device name for OPEN.	*** MJC
18420		MOVEM	A,INTDAT+1	; Move into parm list for OPEN.	*** MJC
18422		OPEN	0,INTDAT  	; Init ch 0 to dump mode.	*** MJC
18426		JRST	NOSEG		; Couldn't do it?		*** MJC
18430		MOVE	A,SGPPPN	; Get ppn of high seg file.	*** MJC
18434		MOVEM	A,HGHDAT+4	; Store for LOOKUP.		*** MJC
18438		LOOKUP	0,HGHDAT+1	; Find file containing high seg	*** MJC
18442		JRST	NOSEG		; No high seg file -- collapse	*** MJC
18446		HLRE	A,HGHDAT+4	; Ppn was replaced by -length	*** MJC
18450		MOVNS	A		; Fix up for CORE2.		*** MJC
18454		CALLI	A,400015	; Grab core for high segment.	*** MJC
18458		JRST	NOSEG		; Can't get it?			*** MJC
18462		MOVE	A,HGHDAT+1	; Name the high segment.	*** MJC
18466		CALLI	A,400036	; SEGNM2 uuo.			*** MJC
18468		JRST	NOSEG		; Pretty weird.			*** MJC
18470		MOVEI	A,SHRST-1	; For dump mode input.		*** MJC
18474		HRRM	A,HGHDAT+4	;				*** MJC
18478		INPUT	0,HGHDAT+4	; Fill high seg with goodies.	*** MJC
18482		CLOSE	0,1		; Destroy fingerprints.		*** MJC
18500		MOVEI	A,DEBUGO	;SET THE REE ADDRESS
18600		HRRM	A,JOBREN
18700		JRST	STRT		;GO TO ALLOCATE STORAGE
18710	NOSEG:	OUTSTR	[ASCIZ/CAN'T GET HIGH SEGMENT!/] ;		*** MJC
18720		HALT					;		*** MJC
18800	HGHDAT:	SYSDEV			; All used by LOOKUP and ENTER	*** MJC
18900		SYSNAM			; High segment job & file name	*** MJC
19000		0			; High seg file extension.	*** MJC
19100		0	
19200		0			; PRG,PPN of high seg file.	*** MJC
19250					; Also file length after LOOKUP	*** MJC
19275					; Used as dump wd cmd list.	*** MJC
19300		0
19310	INTDAT:	17			; Data mode.			*** MJC
19320		SYSDEV			; Dev name (defd before OPEN)	*** MJC
19330		0			; Buffer indicators (none)	*** MJC
19335	SGPPPN:	XWD	SYSPRG,SYSPN	; High seg file area		*** MJC
19340	PATCHL:	BLOCK	20
19350	 >
19400	
19500	
19600	DDT:	SETOM	ERINT	;$$SET CONTROL H WITHOUT GOING THRU REE
19700		JRST	@JOBOPC	;$$AND CONTINUE
19800	
19900	DEBUGO:	SKIPE	GCFLG#	;CHECK GARBASE COLLECT.
20000		PUSHJ	P,GCING	;QUEUE INTERRUPT
20100		INCHRW	0	;READ THE CONTROL CHARACTER
20200		CAIN	0,CNTLH
20300		JRST   [MOVE 0,STNIL
20400			JRST DDT]
20500		CAIN	0,CNTLE
20600		JRST   [MOVE 0,STNIL
20700			MOVEI 1,NIL
20800			JRST ERR]
20900		CAIN	0,CNTLB
21000		JRST   [MOVE 0,STNIL
21100			SETOM ERINT
21200			PUSHJ P,SPDLPT
21300			PUSHJ P,SPREDO
21400			JRST LSPRET]
21500		CAIN	0,CNTLZ
21600		JRST   [MOVE 0,STNIL
21700			JRST LSPRET]
21800		CAIN	0,CNTLG
21900		JRST   [MOVE 0,STNIL
22000			JRST RERX]
22100		JRST	DEBUGO+2	;NOT A CONTROL CHARACTER
22200					;MUST BE SOMETHING IN THE BUFFER SO TRY AGAIN
22300	
22400	START:	CALLI RESET	;random initializations for lisp interupts
22500		MOVE [JSR UUOH]
22600		MOVEM JOB41
22700		MOVEI APRINT
22800		MOVEM JOBAPR
22900		MOVEI APRFLG
23000		CALLI APRINI
23100		SETZM GCFLG
23200		HRRZI 17,1
23300		IFN ALVINE,<SETZB 0,PSAV1>
23400		IFE ALVINE,<SETZ 0,>
23500		BLT 17,17	;clear acs 
23600		MOVE S,ATMOV	;$$SET UP RELOCATION FOR INTERNAL ATOMS (FOOLIST)
23700	LSPRT1:	SETZM	BIOCHN(S)	;$$CLEAR VARS FOR BREAK PACKAGE
23800		SETZM	BPMPT(S)	;$$(#%IOCHNAS%#, #%PROMPTS%#, AND #%INDENT)
23900		MOVEI	A,INUM0
24000		MOVEM	A,BINDNT(S)
24100		SETZM	ERINT#	;$$TURN OFF INTERRUPT FLAG
24200		SETOM ERRSW	;print error messages
24300		CLEARM ERRTN#	;return to top level on errors
24400		SETOM PRVCNT#	;initialize counter for errio
24500		MOVE P,C2#	;initial reg pdl ptr
24600		MOVE SP,SC2#	;initial spec pdl ptr
24700	
24800	
24900		MOVE A,LSPRMP#	;$$INITIALIZE TO TOP LEVEL PROMPT
25000				;$$CAN BE CHANGED BY INITPROMPT
25100		PUSHJ P,PROMPT	;$$
25200	
25300		SETZM	SMAC	;$$CLEAR SPLICE LIST (JUST IN CASE)
25400		MOVE S,ATMOV	;$$SET UP RELOCATION FOR INTERNAL ATOMS (FOOLIST)
25500		PUSHJ P,TTYRET	;(outc nil t)(inc nil t)return output for gc message
25600		HRROI 0,CNIL2(S)	;initialize nil
25700		MOVEM 0,STNIL#		;$$SAVE FOR REG CHECK AT START TIME
25800	IFN HASH,<
25900		SKIPE HASHFG#
26000		JRST REHASH	;rehash if necessary>
26100		SKIPN F	
26200		PUSHJ P,AGC	;garbage collect only if necessary
26300		SKIPN BSFLG#	;initial bootstrap for macros
26400		JRST BOOTS
26500		SKIPE A,INITF
26600		CALLF (A)	;evaluate initialization function
26700		PUSHJ P,TTYRET		;return all i/o to tty
26800		PUSHJ P,TERPRI
26900		SKIPE GOBF#	;garbaged oblist flag
27000		STRTIP [SIXBIT /GARBAGED OBLIST←!/]
27100		SETZM GOBF
27200		SKIPE BPSFLG#
27300		JRST BINER2	;binary program space exceeded by loader
27400	LISP1:	MOVE S,ATMOV#	;$$MAKE SURE REL STAYS
27500					;$$SET UP - BELT AND SUSPENDERS TECHNIQUE
27600		PUSHJ P,READ	;this is the top level of lisp
27700		PUSHJ P,EVAL
27800		PUSHJ P,PRINT
27900		PUSHJ P,TERPRI
28000		JRST LISP1
28100	PAGE
28200	INITFN:	EXCH A,INITF#
28300		POPJ P,
28400	
28500	;return from lisp error
28600	LSPRET:	PUSHJ P,TERPRI
28700		MOVE B,SC2	;RETURN FROM BELL
28800		PUSHJ P,UBD	;unbind specpdl
28900		JRST LSPRT1
29000	
29100	.RSET:	EXCH A,RSTSW#
29200		POPJ P,
29300	
29400	;BOOTSTRAPPER FOR USER'S INIT FILE
29500	BOOTS:	SETOM BSFLG
29600		MOVE A,[POINT 7,[ASCII /(ERRSET[INC(INPUT DSK:(INIT.LSP]NIL)[(EVAL(READ]/]]
29700		MOVEM A,BOOPT#
29800		MOVEI A,BSTYI
29900		PUSHJ P,READP1
30000		PUSHJ P,EVAL
30100		JUMPE A,BOOTOT
30200		MOVEI A,BSTYI
30300		PUSHJ P,READP1
30400		PUSH P,A
30500		MOVE A,(P)
30600		PUSHJ P,ERRSET
30700		CAIE A,$EOF$(S)
30800		JRST .-3
30900	BOOTOT:	PUSHJ P,EXCISE
31000		JRST ERR
31100	
31200	BSTYI:	ILDB A,BOOPT
31300		POPJ P,
31400	PAGE
31500			SUBTTL APR INTERRUPT ROUTINES --- PAGE 3
31600	;arithmetic processor interupts
31700	;mem. protect. violation, nonex. mem. or pdl overflow
31800	
31900	APRINT:	MOVE R,JOBCNI	;get interupt bits
32000		TRNE R,MPV+NXM	;what kind
32100		ERR3 @JOBTPC	;an ill mem ref-will become JRST ILLMEM
32200		JUMPN NIL,MES21	;a pdl overflow
32300		STRTIP [SIXBIT /←PDL OVERFLOW FROM GC - CAN'T CONTINUE!/]
32400		JRST START
32500	
32600	MES21:	SETZM JOBUUO
32700		SKIPL P
32800		STRTIP [SIXBIT /←REG !/]
32900		SKIPL SP
33000		STRTIP [SIXBIT /←SPEC !/]
33100		SKIPE JOBUUO
33200	SPDLOV:	ERR2 [SIXBIT /PUSHDOWN CAPACITY EXCEEDED !/]
33300		TRNE R,PDOV
33400		SKIPE JOBUUO
33500		HALT		;lisp should not be here
33600	BINER2:	SETZM BPSFLG
33700		ERR2 [SIXBIT /BINARY PROGRAM SPACE EXCEEDED !/]
33800	
33900	ILLMEM:	LDB R,[POINT 4,@JOBTPC,XFLD]	;get index field of bad word
34000		CAIE R,F	;does  it contain f
34100		ERR3 @JOBTPC	;no! error
34200		PUSHJ P,AGC	;yes! garbage collect
34300		JRST @JOBTPC	;and continue
34400			SUBTTL UUO HANDLER AND SUBR CALL ROUTINES --- PAGE 4
34500	
34600	UUOMIN==1
34700	UUOMAX==4
34800	
34900	REMOTE<UUOH:	X		;jsr location
35000			JRST	UUOH2>
35100	UUOH2:	MOVEM T,TSV#
35200		MOVEM TT,TTSV#
35300			LDB T,[POINT 9,JOBUUO,OPFLD]	;get opcode
35400		CAIGE T,34	;is it a function call
35500		JRST ERROR	;or a LISP error
35600		HLRE R,@JOBUUO
35700		AOJN R,UUOS
35800		LDB T,[POINT 4,JOBUUO,ACFLD]
35900		CAILE T,15
36000		MOVEI R,-15(T)
36100			HRRZ T,@JOBUUO
36200	UUOH1:	HLRZ TT,(T)
36300		HRRZ T,(T)
36400		CAIN TT,SUBR(S)
36500		JRST @UUST(R)
36600		CAIN TT,FSUBR(S)
36700		JRST @UUFST(R)
36800		CAIN TT,LSUBR(S)
36900		JRST @UULT(R)
37000		CAIN TT,EXPR(S)
37100		JRST @UUET(R)
37200		CAIN TT,FEXPR(S)
37300		JRST @UUFET(R)
37400		HRRZ T,(T)
37500		JUMPN T,UUOH1
37600		PUSH P,A
37700		PUSH P,B
37800		HRRZ A,JOBUUO
37900		MOVEI B,VALUE(S)
38000		PUSHJ P,GET
38100		JUMPN A,[	HRRZ TT,(A)
38200				POP P,B
38300				POP P,A
38400				JRST UUOEX1]
38500		HRRZ A,JOBUUO
38600		PUSHJ P,EPRINT
38700		ERR1 [SIXBIT /UNDEFINED UUO!/]
38800	PAGE
38900		SKIPA T,TT
39000	UUOSBR:	HLRZ T,(T)
39100		MOVE TT,JOBUUO
39200		HRLI T,(PUSHJ P,)
39300		TLNE TT,1000	;1000 means no push
39400		TLCA T,34600	;<PUSHJ P,>xor<JRST>
39500		PUSH P,UUOH
39600		SOS UUOH
39700		HRRZ	D,UUOH
39800		CAIG	D,SHRST
39900		JRST	.+3
40000		SKIPE	WRTSTS
40100		JRST	.+3
40200	REMOTE<UUOCL:	TLNN TT,2000>	;2000 means no clobber
40300		XCT	UUOCL
40400		MOVEM T,@UUOH
40500		MOVE TT,TTSV
40600		EXCH T,TSV
40700		JRST @TSV
40800	
40900	UUOS:	HRRZ TT,JOBUUO
41000		CAILE TT,@GCPP1
41100		CAIL TT,@GCP1
41200		JRST UUOSBR-1
41300		JRST .+2
41400	UUOEXP:	HLRZ TT,(T)
41500	UUOEX1:	LDB T,[POINT 5,JOBUUO,ACFLD]
41600		TRZN T,20
41700		PUSH P,UUOH
41800		PUSH P,TT
41900		JUMPE T,IAPPLY
42000		CAIN T,17
42100		MOVEI T,1
42200		MOVNS T
42300		HRLZ TT,T
42400		PUSH P,A(TT)
42500		AOBJN TT,.-1
42600		JRST IAPPLY
42700	PAGE
42800	ARGPDL:	LDB T,[POINT 4,JOBUUO,ACFLD]
42900		MOVNS T
43000		HRLZ R,T
43100	ARGP1:	JUMPE R,(TT)
43200		PUSH P,A(R)
43300		AOBJN R,.-1
43400		JRST (TT)
43500	
43600	QTIFY:	PUSHJ P,NCONS
43700		MOVEI B,CQUOTE(S)
43800		JRST XCONS
43900	
44000	QTLFY:	MOVEI A,0
44100	QTLFY1:	JUMPE T,(TT)
44200		EXCH A,(P)
44300		PUSHJ P,QTIFY
44400		POP P,B
44500		PUSHJ P,CONS
44600		AOJA T,QTLFY1
44700	
44800	PDLARG:	JRST .+NACS+2(T)
44900		POP P,A+5
45000		POP P,A+4
45100		POP P,A+3
45200		POP P,A+2
45300		POP P,A+1
45400		POP P,A
45500		JRST (TT)
45600	
45700	NOUUO:	MOVSI B,(TLNN TT,)
45800		SKIPE A
45900		MOVSI B,(TLNA)
46000		HLLM B,UUOCL
46100		EXCH A,NOUUOF#
46200		POPJ P,
46300	PAGE
46400	;r=0 => compiler calling a -
46500	;r=1 => compiler calling a lsubr
46600	;r=2 => compiler calling f type
46700	UUST:	UUOSBR
46800		UUOS1	;calling l its a subr
46900		UUOS2	;calling f
47000	
47100	
47200	UUFST:	UUOS9	;calling - its a f
47300		UUOS10	;calling l
47400		UUOSBR
47500	
47600	UULT:	UUOS7	;calling - its a l
47700		UUOSBR
47800		UUOS8
47900	
48000	UUET:	UUOEXP
48100		UUOS5	;calling l its an expr
48200		UUOS6	;calling f its an expr
48300	
48400	UUFET:	UUOS3	;calling - its a fexpr
48500		UUOS4	;calling l
48600		UUOEXP	
48700	
48800	UUOS1:	HLRZ R,(T)
48900		MOVE T,TSV
49000		JSP TT,PDLARG
49100		JRST (R)
49200	
49300	UUOS3:	PUSH P,(T)
49400		JSP TT,ARGPDL
49500	UUOS4A:	JSP TT,QTLFY
49600		MOVEI TT,1
49700		DPB TT,[POINT 4,JOBUUO,ACFLD]
49800	UUOS6A:	POP P,TT
49900			HLRZS TT
50000		JRST UUOEX1
50100	
50200	UUOS4:	PUSH P,(T)
50300		MOVE T,TSV
50400		JRST UUOS4A
50500	PAGE
50600	UUOS5:	HLRZ R,(T)
50700		MOVE T,TSV
50800		JSP TT,PDLARG
50900		MOVE TT,R
51000		JRST UUOEX1
51100	
51200	UUOS6:	PUSH P,(T)
51300		PUSH P,UUOH
51400		PUSH P,JOBUUO
51500		JSP TT,ILIST
51600		JSP TT,PDLARG
51700		POP P,JOBUUO
51800		POP P,UUOH
51900		JRST UUOS6A
52000	UUOS8:	SKIPA TT,CILIST
52100	UUOS7:	MOVEI TT,ARGPDL
52200		HRRM TT,UUOS7A
52300		MOVE TT,JOBUUO
52400		TLNN TT,1000
52500		PUSH P,UUOH
52600		HLRZ TT,(T)
52700		JRST	@UUOS7A	;OR ILIST
52800	REMOTE<UUOS7A:	ARGPDL>
52900	
53000	UUOS9:	PUSH P,T
53100		JSP TT,ARGPDL
53200	UUS10A:	JSP TT,QTLFY
53300		MOVSI T,2000
53400		IORM T,JOBUUO
53500		POP P,T
53600		JRST UUOSBR
53700	
53800	UUOS10:	PUSH P,T
53900		MOVE T,TSV
54000		JRST UUS10A
54100	
54200			SUBTTL ERROR HANDLER AND BACKTRACE --- PAGE 5
54300	;subroutine to print sixbit error message
54400	ERRSUB:	MOVSI A,(POINT 6,0)
54500		HRR A,JOBUUO
54600		MOVEM A,ERRPTR#
54700	ERRORB:	ILDB A,ERRPTR
54800		CAIN A,01	;conversion from sixbit
54900		POPJ P,
55000		CAIN A,77
55100		JRST [	PUSHJ P,TERPRI
55200			JRST ERRORB]
55300		ADDI A,40
55400		PUSHJ P,TYO
55500		JRST ERRORB
55600	
55700	;subroutine to return output to previously selected device
55800	OUTRET:	SKIPL PRVCNT	;if prvcnt<0 then there was no device deselect
55900		SOSL PRVCNT	;when prvcnt goes negative, then reselect
56000		POPJ P,
56100		PUSH P,PRVSEL#		;previously selected output
56200		POP P,TYOD
56300		POPJ P,
56400	
56500	;subroutine to force error messages out on tty
56600	ERRIO:	MOVE B,ERRSW
56700		CAIE B,INUM0	;inum0 specifies to print message on selected device
56800		AOSLE PRVCNT	;only if prvcnt already <0 does deselection occur
56900		POPJ P,	
57000		TALK		;undo control o
57100		MOVE B,[JRST TTYO]
57200		EXCH B,TYOD
57300		MOVEM B,PRVSEL
57400		POPJ P,
57500	
57600	;ERRTN:	0	;0 => top level				*
57700		;- => pdl to reset to - stored by errorset
57800		;+ => string tyo pout rtn flag
57900	REMOTE<ERRSW:	-1>	;0 means no prnt on error		*
58000	PAGE
58100	;subroutine to search oblist for closest function to address in r
58200	ERSUB3:
58300		MOVEI A,QST(S)
58400		HRROI NIL,CNIL2(S)
58500		HRLZ B,INT1
58600		MOVNS B
58700		SETZB AR2A,GOBF
58800		PUSH P,JOBAPR
58900		MOVEI C,[	SETOM GOBF
59000				JRST ERRO2G]
59100		HRRM C,JOBAPR
59200		HLRZ C,@RHX5
59300	ERRO2B:	JUMPE C,[	AOBJN B,.-1
59400				POP P,JOBAPR	;oblist done, restore
59500				JRST PRINC]	;print closest match
59600		HLRZ TT,(C)
59700	ERRO2C:	HRRZ TT,(TT)
59800		JUMPE TT,ERRO2G
59900		HLRZ AR1,(TT)
60000		CAIN AR1,LSUBR(S)
60100		JRST ERRO2H
60200		CAIE AR1,SUBR(S)
60300		CAIN AR1,FSUBR(S)
60400		JRST ERRO2H
60500		HRRZ TT,(TT)
60600		JRST ERRO2C
60700	
60800	ERRO2H:	HRRZ TT,(TT)
60900		HLRZ TT,(TT)
61000		CAMLE TT,AR2A	;le to prefer car to quote
61100		CAMLE TT,R
61200		JRST ERRO2G
61300		MOVE AR2A,TT
61400		HLRZ A,(C)
61500	ERRO2G:	HRRZ C,(C)
61600		JRST ERRO2B
61700	PAGE
61800	;dispatcher for error message uuos
61900	ERROR:	MOVEI A,APRFLG
62000		CALLI A,APRINI	;enable interupts
62100		LDB A,[POINT 9,JOBUUO,OPFLD]	;get opcode
62200		CAIL A,UUOMIN	;what
62300		CAILE A,UUOMAX	;is it?
62400		JRST ILLUUO	;an illegal opcode
62500		JRST @ERRTAB-UUOMIN(A)	;or LISP error
62600	ERRTAB:	ERROR1	;1	;ordinary LISP error
62700		ERRORG	;2	;space overflow error
62800		ERROR2	;3	;ill. mem. ref.
62900		STRTYP	;4	;print error message and continue
63000	ERRORG:	MOVE P,ERRTN	;IF IN ERRSET, RESTORE P TO THAT LEVEL
63100		SKIPN P
63200		MOVE P,C2	;else to top level
63300		SETOM UUO2#	;$$ AND DON'T ENTER ERRORX
63400	
63500	ERROR1:	SKIPN ERRSW
63600		JRST ERREND	;dont print message, call (err nil)
63700		PUSHJ P,ERRIO	;print message on tty
63800		PUSHJ P,TERPRI
63900		PUSHJ P,ERRSUB	;print the message
64000		JRST ERRBK	;go the backtrace
64100	
64200	STRTYP:	PUSHJ P,ERRIO
64300		PUSHJ P,ERRSUB	;print message and continue
64400		PUSHJ P,OUTRET
64500		JRST @UUOH
64600	
64700	;USER ENTRY TO ERROR HANDLER, PRINTS ARG IF NON-NIL
64800	.ERROR:	JUMPE	A,ERREND
64900		SKIPN	ERRSW
65000		JRST	ERREND
65100		PUSHJ	P,ERRIO
65200		PUSHJ	P,TERPRI
65300		PUSHJ	P,PRINC
65400		JRST	ERREND
65500	PAGE
65600	ERROR2:	HRRZ A,JOBUUO
65700		MOVEI B,[SIXBIT / ILL MEM REF FROM !/]
65800		JRST ERSUB2
65900	
66000	ILLUUO:	HRRZ A,UUOH
66100		MOVEI B,[SIXBIT / ILL UUO FROM !/]
66200	ERSUB2:	SKIPN ERRSW
66300		JRST ERREND	;dont print message
66400		PUSH P,A
66500		PUSH P,B
66600		PUSHJ P,ERRIO
66700		PUSHJ P,TERPRI
66800		PUSHJ P,PRINL2	;print number
66900		POP P,A
67000		STRTIP (A)	;print message
67100		POP P,R
67200		PUSHJ P,ERSUB3	;print nearest oblist match
67300	ERRBK:
67400	IFN ALVINE,<
67500		SKIPE BACTRF
67600		PUSHJ P,BKTRC	;print backtrace
67700	>
67800		PUSHJ P,OUTRET	;return to previous device
67900	ERREND:	PUSHJ	P,%CLRBFI	;CLEAR INPUT BUFFER
68000		SKIPN	UUO2		;$$NO ERRORX IF OVERFLOW ERROR
68100		JRST	.+3
68200		SETZM	UUO2		;$$RESET TO ZERO
68300		JRST	RERX	;$$BOUNCE BACK TO ERRORX
68400		SKIPN	RSTSW		;$$NEW *RSET FEATURE
68500		JRST	ERR		;$$IF (*RSET NIL) UNBIND AND GO TO TOP LEVEL
68600		SKIPN	ERRSW		;$$NO ERRORX IF NO MESSAGE
68700		JRST	ERR		;$$
68800		MOVEI	A,ERRORX(S)	;$$ELSE SET TO CALL ERROR HANDLER
68900		MOVEI	B,NIL		;$$CREATE FORM (ERRORX)
69000	CEV:	PUSHJ	P,CONS		;$$
69100		JRST	EVAL		;$$AND EVALUATE IT
69200	
69300	
69400	ERR:	SETZM	INHERR		;CLEAR RERX FLAG JUST IN CASE
69500		CAIN A,ERRORX(S)	;$$BOUNCE TO ERRORX IF A=ERRORX
69600		JRST RERX
69700	ERR2:	SKIPN ERRTN
69800		JRST LSPRET	;not in an errset, or bad error -- go to top level
69900		MOVE P,ERRTN
70000	ERR1:	POP P,B
70100		PUSHJ P,UBD	;unbind to previous errset
70200		POP P,ERRSW
70300		POP P,ERRTN
70400		SKIPN	INHERR#
70500		JRST ERRP4	;and proceed
70600	
70700	RERX:	SETZM	INHERR	;$$ POP TO A BREAK ERRSET
70800		MOVE	B,ERRSW
70900		CAIE	B,ERRORX(S)
71000		SETOM	INHERR
71100		JRST	ERR2
71200	
71300	ERRSET:	PUSH P,PA3
71400		PUSH P,PA4
71500		PUSH P,ERRTN
71600		PUSH P,ERRSW
71700		PUSH P,SP
71800		MOVEM P,ERRTN
71900		HRRZ C,(A)
72000		HLRZ C,(C)
72100		MOVEM C,ERRSW
72200		HLRZ A,(A)
72300			PUSHJ P,EVAL
72400		PUSHJ P,NCONS
72500		SETZM INHERR	;CLEAR RERX FLAG
72600		JRST ERR1
72700	
72800	SYSCLR:	SETZM BSFLG	;FUNCTION TO MAKE SYSTEM LOOK NEW
72900		JRST FALSE	;MIGHT BE EXTENDED LATER
73000	PAGE
73100	;error messages
73200	
73300	
73400	
73500	
73600	RMERR:	MOVE A,T	;$$ BAD READ MACRO, GET THE NAME
73700		PUSHJ P,EPRINT	;$$
73800		ERR1 [SIXBIT /UNDEFINED READ MACRO!/]
73900	BNDERR:	PUSHJ P,EPRINT		;$$ATTEMPT TO REBIND NIL OR T
74000		ERR1 [SIXBIT /CANNOT BE RE-BOUND!/]
74100	
74200	RPAERR:	PUSHJ	P,EPRINT	;$$PRINT OUT OFFENDING ITEM
74300		ERR1 [SIXBIT /IS AN ATOM, CAN'T BE RPLACA'D!/]
74400	
74500	RPDERR:	PUSHJ	P,EPRINT	;$$
74600		ERR1 [SIXBIT /CAN'T BE RPLACD'D (NIL OR INUM)!/]
74700	
74800	DOTERR:	SETZM OLDCH
74900		ERR1 [	SIXBIT /DOT CONTEXT ERROR!/]
75000	UNDFUN:	HLRZ A,(AR1)
75100		PUSHJ P,EPRINT
75200		ERR1 [SIXBIT /UNDEFINED FUNCTION!/]
75300	UNBVAR:	PUSHJ P,EPRINT
75400		ERR1 [SIXBIT /UNBOUND VARIABLE - EVAL!/]
75500	NONNUM:	ERR1 [SIXBIT /NON-NUMERIC ARGUMENT!/]
75600	NOPNAM:	ERR1 [SIXBIT /NO PRINT NAME - INTERN!/]
75700	NOLIST:	ERR1 [SIXBIT /NO LIST-MAKNAM!/]
75800	TOMANY:	ERR1 [SIXBIT /TOO MANY ARGUMENTS SUPPLIED - APPLY!/]
75900	TOOFEW:	ERR1 [SIXBIT /TOO FEW ARGUMENTS SUPPLIED - APPLY!/]
76000	UNDTAC: HRRZ A,(C)
76100	UNDTAG:	PUSHJ P,EPRINT
76200		ERR1 [SIXBIT /UNDEFINED FUNCTION - APPLY!/]
76300	SETERR:	PUSHJ P,EPRINT		;$$BAD SET OR SETQ
76400		ERR1 [SIXBIT /CAN'T BE SET TO A VALUE - SET OR SETQ!/]
76500	EG1:	PUSHJ P,EPRINT
76600		ERR1 [SIXBIT /UNDEFINED PROG TAG-GO!/]
76700	EG2:	PUSHJ P,EPRINT
76800		ERR1 [SIXBIT /GO WITH NO PROG!/]
76900	EG3:	ERR1 [SIXBIT /RETURN WITH NO PROG!/]
77000	PAGE
77100	IFN ALVINE,<
77200	
77300	;backtrace subroutine
77400	BKTRC:	MOVEI D,-1(P)
77500		MOVN A,BACTRF
77600		ADDI A,INUM0
77700		JUMPL A,[	ADD A,P	;backtrace specific number 
77800				JRST .+3]
77900		SKIPN A,ERRTN	;backtrace to previous errset
78000		MOVE A,C2	;or top level
78100		HRRZM A,BAKLEV#
78200		STRTIP [SIXBIT /←BACKTRACE←!/]
78300	BKTR2:	CAMG D,BAKLEV
78400		JRST FALSE	;done 
78500		HRRZ A,(D)	;get pdl element
78600		CAIGE A,FS(S)
78700		JUMPN A,.+2	;this is (hopefully) a true program address
78800		SOJA D,BKTR2	;not a program address, continue
78900		CAIN A,ILIST3
79000		JRST BKTR1A	;argument evaluation 
79100	BKTR1B:	CAIN A,CPOPJ
79200		JRST [	HLRZ A,(D)	;calling a function
79300			PUSHJ P,PRINC
79400			XCT "-",CTY
79500			STRTIP [SIXBIT /ENTER !/]
79600			SOJA D,BKTR2]
79700		HLRZ B,-1(A)
79800		CAILE B,(JCALLF 17,@(17))
79900		CAIN B,(PUSHJ P,)	;tests for various types of calls
80000		CAIGE B,(FCALL)
80100		SOJA D,BKTR2		;not a proper function call
80200		PUSH P,-1(A)	;save object of function call
80300		MOVEI R,-1(A)	;location of function call
80400		PUSHJ P,ERSUB3		;print closest oblist match
80500		MOVEI A,"-"
80600		PUSHJ P,TYO
80700		POP P,R
80800		TLNE R,17
80900		HRRZ R,ERSUB3	;qst -- cant handle indexed calls
81000		HRRZS R
81100		HLRO B,(R)
81200		AOSN B
81300		JRST [	HRRZ A,R	;was calling an atomic function
81400			PUSHJ P,PRINC	;print its name
81500			JRST .+2]
81600		PUSHJ P,ERSUB3	;was calling a code location -- print closest match
81700		MOVEI A," "
81800		PUSHJ P,TYO
81900	BKTR1:	SOJA D,BKTR2	;continue
82000	
82100	BKTR1A:	HRRZ B,-1(D)
82200		CAIE B,EXP2
82300		CAIN B,ESB1
82400		JRST .+2
82500		JRST BKTR1B	;hum, not really evaluating arguments
82600		HLRE B,-1(D)
82700		ADD B,D
82800		HLRZ A,-3(B)
82900		JUMPE A,BKTR1
83000		PUSHJ P,PRINC
83100		XCT "-",CTY
83200		STRTIP [SIXBIT /EVALARGS !/]
83300		JRST BKTR1
83400	>
83500	
83600	BAKGAG:	EXCH A,BACTRF#
83700		POPJ P,
     

00100			SUBTTL TYI  AND TYO  --- PAGE 6
00200	;input
00300	ITYI:	PUSHJ P,TYI
00400	FIXI:	ADDI A,INUM0
00500		POPJ P,
00600	
00700	TYI:	MOVEI AR1,1
00800		PUSHJ P,TYIA
00900		JUMPE A,.-1
01000		CAME A,IGSTRT	;start of comment or ignored cr-lf
01100		POPJ P,
01200		PUSHJ P,COMMENT
01300		JRST TYI+1
01400	
01500	TYIA:	SKIPE A,OLDCH
01600		JRST TYI1
01700	TYID:	XCT	TYI2
01800	REMOTE<TYI2:	JRST TTYI>	;sosg x for other device input
01900		;other device input
02000		JRST TYI2X
02100	TYI3B:	ILDB A,@TYI3#		;pointer
02200		XCT	TYI3A
02300	REMOTE<TYI3A:	TDNN AR1,@X>	;pointer
02400		POPJ P,
02500	IFN STPGAP,<
02600		MOVE A,@TYI3A
02700		CAMN A,[<ASCII /     />+1]	;page mark for stopgap
02800		AOSA PGNUM	;increment page number
02900		MOVEM A,LINUM
03000	>
03100		MOVNI A,5
03200		ADDM A,@TYI2	;adjust character count for line number
03300		AOS @TYI3	;increment byte pointer over line number and tab
03400		JRST TYID
03500	
03600	REMOTE<	TYI2X:	INPUT X,
03700		TYI2Y:	STATZ X,740000
03800			ERR1 AIN.8	;input error
03900		TYI2Z:	STATO X,20000
04000			JRST TYI3B	;continue with file
04100			JRST	TYI2Q		;END OF FILE>
04200	TYI2Q:	PUSH P,T
04300		PUSH P,C
04400		PUSH P,R
04500		PUSH P,AR1
04600		MOVE A,INCH
04700		HRRZ C,CHTAB(A)	;get location of data for this channel
04800		HLRZ T,CHTAB(A)	;inlst	-- remaining files to input
04900		JUMPE T,TYI2E	;none left -- stop
05000		PUSHJ P,SETIN	;start next input
05100		POP P,AR1
05200		POP P,R
05300		POP P,C
05400		POP P,T
05500		JRST TYI
05600	
05700	TYI2E:	PUSHJ P,INCNT	;(inc nil t)
05800		TALK		;turn off control o
05900		MOVEI A,$EOF$(S)	;we are done
06000		JRST ERR
06100	
06200	IFN STPGAP,<
06300	PGLINE:	MOVE C,[POINT 7,LINUM]
06400		PUSHJ P,NUM10	;convert ascii line number to a integer
06500		ADDI A,INUM0
06600		MOVE B,PGNUM
06700		ADDI B,INUM0+1
06800		JRST XCONS>
06900	
07000	REMOTE<	OLDCH:	0
07100	IFN STPGAP,<
07200		PGNUM:	0
07300		LINUM:	0
07400			0>>	;zero to terminate num10
07500	
07600	;TTYECHO - COMPLEMENTS THE TTY: ECHO BIT AND RETURNS T IF THE ECHO
07700	;	   IS BEING TURNED ON AND NIL IF IT IS BEING TURNED OFF
07800	;	 - TAKES NO ARGUMENTS
07900	ECHO:	SETO	A,
08000		TTYUUO	6,A	;GET STATUS BITS
08100		TLC	A,4	;COMPLEMENT THE ECHO BIT
08200		TTYUUO	7,A	;RESTORE THE BITS
08300		TLNE	A,4	;TEST TO GET FINAL VALUE
08400		JRST	FALSE
08500		JRST	TRUE
08600	
08700	;CLRBFI - CLEARS TTY INPUT BUFFER FOR USER ERRORS
08800	;       - 0 ARGS AND RETURNS NIL
08900	%CLRBFI:CLRBFI		;CLEAR BUFFER
09000		SETZM	SMAC	;CLEAR SPLICE LIST
09100		SETZM	OLDCH	;CLEAR LAST CHAR.
09200		JRST	FALSE
09300	PAGE
09400	;teletype input
09500	
09600	TTYI:	SKIPE DDTIFG
09700		JRST TTYID
09800		INCHSL A	;single char if line has been typed
09900		JRST 	[TALK		;turn off control o, this
10000					;can be omitted when ttyser is fixed
10100			OUTCHR PROMCH#	;$$OUTPUT PROMPT CHARACTER		
10200			INCHWL A	;wait for a line
10300			JRST .+1]
10400	TTYXIT:	CAIE	A,BELL
10500		POPJ	P,
10600	IFN ALVINE,<
10700		SKIPE PSAV1#	;bell from alvine?
10800		JRST [	MOVE P,PSAV1	;yes, return to alvine
10900			JRST @ED1];$$DOUBLY IMPROVED MAGIC>
11000		MOVEI	A,NIL	;$$ RETURN NIL AS THE VALUE
11100		JRST	RERX	;$$ RETURN TO AN ERRORX ERRSET
11200	
11300	TTYID:	TALK		;turn off control o, remove this when ttyser works
11400		INCHRW A	;single character input ddt submode style
11500		CAIE A,RUBOUT
11600		JRST TTYXIT
11700		OUTCHR ["\"]	;echo backslash
11800		SKIPE PSAV
11900		JRST RDRUB	;rubout in read resets to top level of read
12000		MOVEI A,RUBOUT	
12100		POPJ P,
12200	
12300	
12400	PROMPT:	SKIPN A
12500		SKIPA A,PROMCH
12600		MOVEI A,-INUM0(A)	;$$CHANGE FROM INUM
12700		EXCH A,PROMCH#		;$$CHANGE PROMPT CHARACTER AND RETURN OLD ONE
12800		MOVEI A,INUM0(A)	;$$CHANGE TO INUM
12900		POPJ P,	;$$
13000	
13100	
13200	INTPRP:	SKIPN A
13300		SKIPA A,LSPRMP
13400		EXCH A,LSPRMP#		;$$ EXCHANGE FOR OLD TOP LEVEL PROMPT
13500		POPJ P,			;$$
13600	
13700	READP:	SKPINC		;$$ T IFF A CHARACTER HAS BEEN TYPED
13800		JRST	FALSE	;$$ (DOES NOT CHECK OLDCH)
13900		JRST	TRUE
14000	
14100	UNTYI:	MOVEI	B,-INUM0(A)	;$$ UN-READ A CHARACTER (PUT IT IN OLDCH)
14200		MOVEM	B,OLDCH
14300		POPJ	P,		;$$ RETURN ARG AS VALUE
14400	PAGE
14500		;output
14600	ITYO:	SUBI A,INUM0
14700		PUSHJ P,TYO
14800		JRST FIXI
14900	
15000	TYO:	CAIG A,CR
15100		JRST TYO3
15200		SOSGE CHCT
15300		JRST TYO1
15400		JRST	TYOD
15500	REMOTE<TYOD:	JRST TTYO+X	;sosg x for other device
15600					;other device output
15700			JRST TYO2X
15800		TYO5:	IDPB A,X
15900			POPJ P,
16000		
16100		TYO2X:	OUT X,
16200			JRST TYO5
16300			ERR1 [SIXBIT /OUTPUT ERROR!/]>
16400	
16500	TYO1:	PUSH P,A	;linelength exceeded
16600		MOVEI A,IGCRLF	;inored cr-lf
16700		PUSHJ P,TYOD
16800		PUSHJ P,TERPRI	;force out a cr-lf, with special mark
16900			POP P,A
17000		SOSA CHCT
17100	TYO4:	POP P,B
17200		JRST TYOD
17300	
17400	TYO3:	CAIGE A,TAB
17500		JUMPN A,TYO+2	;everything between 0(null) and 11(tab) decrement chct
17600		PUSH P,B
17700		MOVE B,LINL
17800		CAIN A,TAB
17900		JRST [	SUB B,CHCT
18000			IORI B,7	;simulate tab effect on chct
18100			SUB B,LINL
18200			SETCAM B,CHCT
18300			JRST TYO4]
18400		CAIN A,CR
18500		MOVEM B,CHCT	;reset chct after a cr
18600		JRST TYO4
18700	
18800	LINELENGTH:
18900		JUMPE A,LINEL1
19000		SUBI A,INUM0
19100		HRRM A,LINL
19200		HRRM A,CHCT
19300	LINEL1:	HRRZ A,LINL
19400			JRST FIXI
19500	
19600	CHRCT:	MOVE A,CHCT
19700		JRST FIXI
19800	
19900	REMOTE<
20000	LINL:	TTYLL
20100	CHCT:	TTYLL>
20200	
20300	;teletype output
20400	TTYO:	OUTCHR A	;output single character in a
20500		POPJ P,
20600	PAGE
20700	REMOTE<DDTIFG:	TRUTH>
20800	DDTIN:	EXCH A,DDTIFG
20900		POPJ P,
21000	
21100	
21200	TTYRET:	PUSHJ P,OUTCNT
21300		JRST INCNT
21400	;THIS IS THE NEW, FAST, AND SHORT ROUTINE TO TURN OFF CONTROL O
21500	TTYCLR:	SKPINC
21600		CAI
21700		POPJ	P,
21800	
21900	REMOTE<
22000	TTOCH:	0
22100	IFN STPGAP,<
22200		0	;tty page number  always zero
22300		0	;tty line number -- always zero
22400	>
22500	TTOLL:	TTYLL
22600	TTOHP:	TTYLL>
22700	PAGE
22800			SUBTTL INPUT AND OUTPUT INITIALIZATION AND CONTROL --- PAGE 7
22900	;convert ascii to sixbit for device initialization routines
23000	SIXMAK:	SETZM SIXMK2#
23100		MOVE AR1,[POINT 6,SIXMK2]
23200		HRROI R,SIXMK1
23300		PUSHJ P,PRINTA	;use print to unpack ascii characters
23400		MOVE A,SIXMK2
23500		POPJ P,
23600	
23700	SIXMK1:	ADDI A,40
23800		TLNN AR1,770000
23900		POPJ P,		;last character position -- ignore remaining chars
24000		CAIN A,"."+40	
24100		MOVEI A,0	;ignore dots at end of numbers for decimal base
24200		CAIN A,":"+40
24300		HRLI AR1,(POINT 6,0,29)	;deposit : in last char position
24400		IDPB A,AR1
24500		POPJ P,
24600	
24700	;subroutine to process next item in file name list
24800		INXTIO:	JUMPE T,NXTIO
24900		HRRZ T,(T)
25000	NXTIO:	HLRZ A,(T)
25100		PUSHJ P,ATOM
25200		JUMPE A,CPOPJ	;non-atomic
25300		HLRZ A,(T)
25400		JRST SIXMAK	;make sixbit if atomic
25500	
25600	;right normalize sixbit
25700		LSH A,-6
25800	SIXRT:	TRNN A,77
25900		JRST .-2
26000		POPJ P,
26100	PAGE
26200	IOSUB:	PUSHJ P,NXTIO
26300		MOVEM T,DEVDAT#
26400		LDB B,[POINT 6,A,35]
26500		JUMPE A,IOPPN	;non-atomic item, must be ppn or (file.ext)
26600		CAIE B,":"-40
26700		JRST IOFIL	;not a device name -- must be file name
26800		TRZ A,77	;clear out the :
26900		SETZM PPN
27000		IODEV2:	MOVEM A,DEV
27100		PUSHJ P,INXTIO
27200	IOPPN:	JUMPN A,IOFIL	;not ppn or (fil.ext)
27300		PUSHJ P,PPNEXT
27400		JUMPN A,IOEXT	;(fil.ext)
27500		HLRZ A,(T)
27600		HLRZ A,(A)	;caar is project number
27700	IFE STANSW,<	HRRZI A,-INUM0(A)	;$$ASSUME PROJECT NUMBER IS AN INUM>
27710	IFN STANSW,<	PUSHJ P,SIXMAK
27720		PUSHJ P,SIXRT>
27800		HRLM A,PPN	;project number
27900		HLRZ A,(T)
28000		PUSHJ P,CADR	;cadar is programmer number
28100	IFE STANSW,<	HRRZI A,-INUM0(A)	;$$ASSUME PROGRAMMER NUMBER IS AN INUM>
28110	IFN STANSW,<	PUSHJ P,SIXMAK
28120		PUSHJ P,SIXRT>
28200		HRRM A,PPN	;programmer number
28300		HRLZI A,(SIXBIT /DSK/)	;disk is assumed
28400		JRST IODEV2
28500	
28600	IOFIL:	SKIPN DEV
28700		JRST AIN.1	;no device named
28800		JUMPN A,IOFIL2	;was it an atom
28900		JUMPE T,CPOPJ	;no, was it nil (end)
29000		PUSHJ P,PPNEXT
29100		JUMPE A,CPOPJ	;see a ppn, no file named
29200	IOEXT:	HLRZ A,(T)	;(file.ext)
29300		HRRZ A,(A)	;get cdr == extension
29400		PUSHJ P,SIXMAK
29500		HLLM A,EXT
29600		HLRZ A,(T)
29700		HLRZ A,(A)	;get car = file name
29800		PUSHJ P,SIXMAK
29900	FIL:	PUSH P,A
30000		PUSHJ P,INXTIO
30100		JRST POPAJ
30200	
30300	IOFIL2:	CAIN B,":"-40
30400		POPJ P,		;saw a :,not file name
30500		SETZM EXT	;file name -- clear extension
30600		JRST FIL
30700	
30800	PPNEXT:	JUMPE T,CPOPJ	;end of file name list
30900			HLRZ A,(T)
31000		HRRZ A,(A)	;cdar
31100		JRST ATOM	;ppn iff (not(atom(cdar l)))
31200	
31300	CHNSUB:	MOVE T,A
31400		HLRZ A,(T)
31500		PUSHJ P,ATOM
31600		JUMPE A,TRUE	;non-atomic head of list -- no channel named
31700		HLRZ A,(T)
31800		PUSHJ P,SIXMAK
31900		ANDI A,77
32000		CAIN A,":"-40
32100		JRST TRUE	;device name, assume channel name t
32200		HLRZ A,(T)	;channel name -- return it
32300		HRRZ T,(T)
32400		POPJ P,
32500	
32600	REMOTE<
32700	CHTAB=.-FSTCH
32800		BLOCK NIOCH>
32900	
33000	;channel data
33100	CHNAM==0	;name of channel
33200	CHDEV==1	;name of device
33300	CHPPN==2	;ppn for input channel
33400	CHOCH==3	;oldch for input channels
33500	IFN STPGAP,<
33600	CHPAGE==4	;page number for input
33700	CHLINE==5	;line number for input
33800	CHDAT==6	;device data
33900	POINTR==7	;byte pointer for device buffer
34000	COUNT==10	;character count for device buffer
34100	>
34200	IFE STPGAP,<
34300	CHDAT==4
34400	POINTR==5
34500	COUNT==6
34600	>
34700	CHLL==2		;linelength for output channel
34800	CHHP==3		;hposit for output channels
34900	PAGE
35000	;search for channel name in chtab
35100	TABSR1:	MOVE A,[XWD -NIOCH,FSTCH]
35200		MOVE C,CHTAB(A)
35300		CAME B,CHNAM(C)
35400		AOBJN A,.-2
35500		CAMN B,CHNAM(C)
35600		POPJ P,	;found it!!!
35700			JRST FALSE	;lost
35800	
35900	;search for channel name in chtab, and if not there find a free channel, and
36000	;if no free channel, allocate a new buffer and channel
36100	TABSRC:	MOVE B,A
36200		PUSHJ P,TABSR1
36300		JUMPN A,DEVCLR	;found the channel
36400		PUSH P,B
36500		MOVE B,0
36600		PUSHJ P,TABSR1	;find a physical channel no. for a free channel
36700		JUMPE A,[ERR1 [SIXBIT $NO I/O CHANNELS LEFT !$]]
36800		POP P,B
36900		JUMPN C,DEVCLR	;found free channel which had buffer space previously
37000		PUSH P,A	;must allocate new buffer
37100		MOVEI A,BLKSIZ
37200		SETZ	D,	;SPECIAL RELOCATION - SEE LOAD
37300		PUSHJ P,MORCOR	;expand core for buffer if necessary
37400		MOVE C,A
37500		POP P,A
37600		HRRM C,CHTAB(A)
37700	DEVCLR:	HRRZ C,CHTAB(A)
37800		HRRZM B,CHNAM(C)	;store name
37900		HRRZM A,CHANNEL#
38000		POPJ P,
38100	
38200	;subroutine to reset all i/o channels	-- used by excise and realloc
38300	IOBRST:	HRRZ A,JOBREL
38400		HRLM A,JOBSA
38500		MOVEM A,CORUSE#
38600		MOVEM A,JOBSYM
38700		SETZM CHTAB+FSTCH
38800		MOVE A,[XWD CHTAB+FSTCH,CHTAB+FSTCH+1]
38900		BLT A,CHTAB+NIOCH+FSTCH-1	;clear channel table
39000		JRST (R)
39100	PAGE
39200	INPUT:	PUSHJ P,CHNSUB	;determine channel name
39300		PUSH P,A
39400		PUSHJ P,TABSRC	;get physical channel number
39500		PUSHJ P,SETIN	;init device
39600		JRST POPAJ
39700	
39800	SETIN:	MOVEM A,CHANNEL
39900		MOVE A,CHDEV(C)
40000		MOVEM A,DEV
40100		MOVE A,CHPPN(C)
40200		MOVEM A,PPN
40300		PUSHJ P,IOSUB	;get device and file name
40400		MOVEM A,LOOKIN	;file name
40500		MOVE A,DEV
40600		CALLI A,DEVCHR
40700		TLNN A,INB
40800		JRST AIN.2	;not input device
40900		TLNN A,AVLB
41000		JRST AIN.4	;not available
41100		MOVE A,CHANNEL
41200		DPB A,[POINT 4,ININIT,ACFLD]	;set up channel numbers
41300		DPB A,[POINT 4,INLOOK,ACFLD]
41400		DPB A,[POINT 4,ININBF,ACFLD]
41500		HRRZ B,CHTAB(A)
41600		HRLM T,CHTAB(A)		;save remaining file name list
41700		MOVEI A,CHDAT(B)
41800		MOVEM A,DEV+1		;pointer to bufdat
41900		JRST ININIT
42000	REMOTE<
42100	ININIT:	INIT X,
42200	DEV:	X
42300		X
42400		JRST AIN.7		;cant init
42500		PUSH B,DEV
42600		PUSH B,PPN
42700	INLOOK:	LOOKUP X,LOOKIN
42800		JRST AIN.7		;cant find file
42900		JRST IRET1>
43000	IRET1:	PUSH B,[0]	;oldch
43100	IFN STPGAP,<
43200		PUSH B,[0]	;line number
43300		PUSH B,[0]	;page number
43400	>
43500		ADDI B,4
43600		HRRM B,JOBFF
43700		JRST ININBF
43800	REMOTE<
43900	ININBF:	INBUF X,NIOB
44000		JRST TRUE
44100	
44200	ENTR:
44300	LOOKIN:	BLOCK 4
44400	EXT=LOOKIN+1
44500	PPN=LOOKIN+3	
44600	>
44700	PAGE
44800	OUTPUT:	PUSHJ P,CHNSUB	;get channel name
44900		PUSH P,A
45000		TRO A,400000	;set bit for output
45100		PUSHJ P,TABSRC	;get physical channel nuber
45200		PUSHJ P,IOSUB	;get device and file name
45300		MOVEM A,ENTR	;file name
45400		SETZM ENTR+2	;zero creation date
45500		MOVE A,CHANNEL
45600		DPB A,[POINT 4,AOUT2,ACFLD]	;setup channel numbers
45700		DPB A,[POINT 4,OUTENT,ACFLD]
45800		DPB A,[POINT 4,OUTOBF,ACFLD]
45900		HRRZ B,CHTAB(A)
46000		MOVEI A,CHDAT(B)
46100		HRLM A,AOUT3+1
46200		MOVE A,DEV
46300		MOVEM A,AOUT3
46400		CALLI A,DEVCHR
46500		TLNN A,OUTB
46600		JRST AOUT.2	;not output device
46700		TLNN A,AVLB
46800		JRST AOUT.4	;not available
46900		JRST AOUT2
47000	REMOTE<
47100	AOUT2:	INIT X,
47200	AOUT3:	X
47300		X
47400		JRST AOUT.4	;cant init
47500		PUSH B,DEV
47600	OUTENT:	ENTER X,ENTR
47700		JRST OUTERR	;cant enter
47800		JRST ORET1>
47900	ORET1:	PUSH B,[LPTLL]		;linelength
48000		PUSH B,[LPTLL]		;chrct
48100		IFE STPGAP,<	ADDI B,4>
48200		IFN STPGAP,<	ADDI B,6>
48300		HRRM B,JOBFF
48400		XCT OUTOBF
48500	REMOTE<
48600	OUTOBF:	OUTBUF X,NIOB
48700	>
48800		JRST POPAJ
48900	
49000	OUTERR:	PUSHJ P,AIOP
49100		LDB A,[POINT 3,ENTR+1,35]
49200		CAIE A,2
49300		ERR1 [SIXBIT /DIRECTORY FULL !/]
49400		ERR1 [SIXBIT /FILE IS WRITE PROTECTED !/]
49500	PAGE
49600	IOSEL:	MOVE C,-1(P)
49700		JUMPE C,CPOPJ	;tty 
49800		JUMPE B,IOSELZ	;dont release
49900		DPB C,[POINT 4,RLS,ACFLD]
50000		XCT RLS
50100	REMOTE<
50200	RLS:	RELEASE X,		;release channel
50300	>
50400		HRRZS CHTAB(C)		;release channel table entry
50500		MOVEM 0,@CHTAB(C)	;blast channel name
50600		SETZM -1(P)
50700	IOSELZ:	HRRZ C,CHTAB(C)
50800		POPJ P,
50900	PAGE
51000	INCNT:	MOVEI A,NIL	;(INC NIL T)
51100		MOVEI B,TRUTH(S)
51200	
51300	INC:	PUSH P,INCH#
51400		PUSHJ P,IOSEL
51500		JUMPN B,INC2	;released channel
51600		SKIPN C
51700		MOVEI C,TTOCH-CHOCH	;tty deselect
51800	IFN STPGAP,<
51900		MOVEI B,CHOCH(C)
52000		HRLI B,OLDCH
52100		BLT B,CHLINE(C)		;save channel data
52200	>
52300	IFE STPGAP,<
52400		MOVE B,OLDCH
52500		MOVEM B,CHOCH(C)
52600	>
52700		JRST	INC2+1
52800	INC2:	SETZM	INCH		;CLEAR CHANNEL NOW IN CASE OF BREAK
52900		JUMPE A,ITTYRE		;select tty
53000		MOVE B,A
53100		PUSHJ P,TABSR1		;determine physical channel number
53200		JUMPE A,[ERR1 [SIXBIT/NO INPUT - INC!/]]
53300		HRRZM A,INCH
53400		DPB A,[POINT 4,TYI2X,ACFLD]	;set up channel numbers
53500		DPB A,[POINT 4,TYI2Y,ACFLD]
53600		DPB A,[POINT 4,TYI2Z,ACFLD]
53700		HRRZ A,CHTAB(A)
53800		MOVEI T,COUNT(A)
53900		HRLI T,(SOSG)
54000		MOVEI B,POINTR(A)
54100		HRRM B,TYI3	;set up tyi parameters
54200		HRRM B,TYI3A
54300	INC3:
54400	IFN STPGAP,<
54500		MOVSI B,CHOCH(A)
54600		HRRI B,OLDCH
54700		BLT B,LINUM	;restore channel data
54800	>
54900	IFE STPGAP,<
55000		MOVE B,CHOCH(A)
55100		MOVEM B,OLDCH
55200	>
55300		MOVEM T,TYI2
55400	IOEND:	POP P,A
55500		JUMPE A,CPOPJ
55600		MOVE A,CHTAB(A)	;get channel name
55700		HRRZ A,(A)
55800		TRZ A,400000	;clear output bit
55900		POPJ P,
56000	
56100	ITTYRE:	SETZM INCH
56200		MOVE T,[JRST TTYI]	;reselect tty
56300		MOVEI A,TTOCH-CHOCH
56400		JRST INC3
56500	PAGE
56600	OUTCNT:	MOVEI A,0	;(outc nil t)
56700		MOVEI B,1
56800	
56900	OUTC:	PUSH P,OUTCH#
57000		PUSHJ P,IOSEL
57100		JUMPN B,OUTC2	;closed this file
57200			SKIPN C
57300		MOVEI C,TTOLL-CHLL	;tty deselect
57400		MOVE B,CHCT
57500		MOVEM B,CHHP(C)		;save channel data
57600		MOVE B,LINL
57700		MOVEM B,CHLL(C)
57800		JRST	OUTC2+1
57900	OUTC2:	SETZM	OUTCH		;CLEAR CHANNEL NOW IN CASE OF BREAK
58000		JUMPE A,OTTYRE		;return to tty
58100		TRO A,400000		;set output bit
58200		MOVE B,A
58300		PUSHJ P,TABSR1		;determine physical channel number
58400		JUMPE A,[ERR1 [SIXBIT /NO OUTPUT - OUTC!/]]
58500		DPB A,[POINT 4,TYO2X,ACFLD]	;set up tyo2 channel numbers
58600		HRRZM A,OUTCH
58700		HRRZ A,CHTAB(A)
58800		MOVEI B,POINTR(A)
58900		HRRM B,TYO5	;set up tyo2 parameters
59000		MOVEI T,COUNT(A)
59100		HRLI T,(SOSG)
59200	OUTC3:	MOVE B,CHLL(A)
59300		MOVEM B,LINL
59400		MOVE B,CHHP(A)
59500		MOVEM B,CHCT
59600		MOVEM T,TYOD
59700		JRST IOEND
59800	
59900	OTTYRE:	SETZM OUTCH
60000		MOVE T,[JRST TTYO]
60100		MOVEI A,TTOLL-CHLL	;tty reselect
60200		JRST OUTC3
60300	PAGE
60400	AIN.1:	PUSHJ P,AIOP
60500		ERR1 [SIXBIT $ILLEGAL I/O ARG!$]
60600	AOUT.2:
60700	AIN.2:	PUSHJ P,AIOP
60800		ERR1 [SIXBIT /ILLEGAL DEVICE!/]
60900	AOUT.4:
61000	AIN.4:	PUSHJ P,AIOP
61100		ERR1 [SIXBIT /DEVICE NOT AVAILABLE !/]
61200	AIN.7:	PUSHJ P,AIOP
61300		ERR1 [SIXBIT /CAN'T FIND FILE - INPUT!/]
61400	
61500		AIN.8:	SIXBIT /INPUT ERROR!/
61600	
61700	AIOP:	MOVE A,DEVDAT
61800		JRST EPRINT
     

00100			SUBTTL PRINT     --- PAGE 8
00200	
00300	EPRINT:	SKIPN ERRSW
00400		POPJ P,
00500		PUSHJ P,ERRIO
00600		PUSHJ P,PRINT
00700		JRST OUTRET
00800	
00900	PRINT:	MOVEI R,TYO
01000		PUSHJ P,TERPRI
01100		PUSHJ P,PRIN1
01200		XCT " ",CTY
01300		POPJ P,
01400	
01500	PRINC:	SKIPA R,.+1
01600	PRIN1:	HRRZI R,TYO
01700		PUSH P,A
01800		PUSHJ P,PRINTA
01900		JRST POPAJ
02000	
02100	PRINTA:	PUSH P,A
02200		MOVEI B,PRIN3
02300		SKIPGE R
02400		MOVEI B,PRIN4
02500		HRRM B,PRIN5
02600		PUSHJ P,PATOM
02700		JUMPN A,PRINT1
02800		XCT "(",CTY
02900	PRINT3:	HLRZ A,@(P)
03000		PUSHJ P,PRINTA
03100		HRRZ A,@(P)
03200		JUMPE A,PRINT2
03300		MOVEM A,(P)
03400		XCT " ",CTY
03500		PUSHJ P,PATOM
03600		JUMPE A,PRINT3
03700		XCT ".",CTY
03800		XCT " ",CTY
03900		PUSHJ P,PRIN1A
04000	PRINT2:	XCT ")",CTY
04100		JRST POPAJ
04200	
04300	PRINT1:	PUSHJ P,PRIN1A
04400		JRST POPAJ
04500	PAGE
04600	PRIN1A:	MOVE A,-1(P)
04700		CAILE A,INUMIN
04800		JRST PRINIC
04900		JUMPE A,PRIN1B
05000		CAIGE A,@GCP1
05100		CAIGE A,@GCPP1
05200		JRST PRINL
05300	PRIN1B:	HRRZ A,(A)
05400		JUMPE A,PRINL
05500		HLRZ B,(A)
05600		HRRZ A,(A)
05700		CAIN B,PNAME(S)
05800		JRST PRINN
05900		CAIN B,FIXNUM(S)
06000		JRST PRINI1
06100		CAIN B,FLONUM(S)
06200		JRSTF @[XWD 0,PRINO]	; TURN OFF DIVIDE CHECK AND UNDERFLOW
06300	BPR:	JRST PRIN1B	;bignums change here to JRST BPRINT
06400		JRST PRIN1B
06500	
06600	PRINL2:	MOVEI R,TYO
06700		JRST PRINL1
06800	
06900	PRINL:	XCT "#",CTY
07000		HRRZ A,-1(P)
07100	PRINL1:	MOVEI C,8
07200		JRST PRINI3
07300	
07400	PRINI1:	SKIPA A,(A)
07500	PRINIC:	SUBI A,INUM0
07600		HRRZ C,VBASE(S)
07700		SUBI C,INUM0
07800		JUMPGE A,PRINI2
07900		XCT "-",CTY
08000		MOVNS A
08100	PRINI2:	MOVEI B,"."-"0"
08200		HRLM B,(P)
08300		CAIN C,TEN
08400		SKIPE %NOPOINT(S)
08500		JRST .+2
08600		PUSH P,PRINI4
08700	PRINI3:	JUMPL A,[	MOVEI B,0	;case of -2↑35
08800				MOVEI A,1
08900				DIVI A,(C)
09000				JRST .+2]
09100		IDIVI A,0(C)
09200		HRLM B,(P)
09300		SKIPE A
09400		PUSHJ P,.-3
09500	PRINI4:	JRST FP7A1
09600	
09700	PRINN:	HLRZ A,(A)
09800		MOVEI C,2(SP)
09900		PUSHJ P,PNAMU3
10000		PUSH C,[0]
10100		HRLI C,(POINT 7,0,35)
10200		HRRI C,2(SP)
10300		ILDB A,C
10400		JUMPE A,CPOPJ		;special case of null character
10500		CAIN A,DBLQT
10600		JRST PSTR	;string
10700	PRIN2X:	LDB B,[POINT 1,CHRTAB(A),1]
10800		JUMPL R,PRIN4	;never slash
10900		JRST PRIN2(B)	;1 for no slash
11000	
11100	PRIN3:	SKIPL CHRTAB(A)	;<0 for no slash
11200	PRIN2:	XCT "/",CTY
11300	PRIN4:	PUSHJ P,(R)
11400		ILDB A,C
11500		JUMPN A,@PRIN5#
11600		POPJ P,
11700	
11800	PSTR:	MOVS B,(C)
11900		CAIN B,(<ASCII /"/>)
12000		JRST PRIN2X	;special case of /"
12100	PSTR3:	SKIPL R		;dont print " if no slashify
12200	PSTR2:	PUSHJ P,(R)
12300		ILDB A,C
12400		CAIE A,DBLQT
12500		JUMPN A,PSTR2
12600		JUMPN A,PSTR3
12700		POPJ P,
12800	
12900	TERPRI:	PUSH P,A
13000		MOVEI A,CR
13100		PUSHJ P,TYO
13200		MOVEI A,LF
13300		PUSHJ P,TYO
13400		JRST POPAJ
13500	
13600	CTY:	JSA A,TYOI
13700	REMOTE<
13800	TYOI:	X
13900		JRST TYOI2>
14000	TYOI2:	PUSH P,A
14100		LDB A,[POINT 6,-1(A),ACFLD]
14200		PUSHJ P,(R)
14300		POP P,A
14400		JRA A,(A)
14500	
14600	PRINO:	MOVE A,(A)
14700		CLEARB B,C
14800		JUMPG A,FP1
14900		JUMPE A,FP3
15000		MOVNS A
15100		XCT "-",CTY
15200	FP1:	CAMGE A,FT01
15300		JRST FP4
15400		CAML A,FT8
15500		AOJA B,FP4
15600	
15700	FP3:	MULI A,400
15800		ASHC B,-243(A)
15900		MOVE A,B
16000		CLEARM FPTEM#
16100		PUSHJ P,FP7
16200		XCT ".",CTY
16300		MOVNI T,8
16400		ADD T,FPTEM
16500		MOVE B,C
16600	
16700	FP3A:	MOVE A,B
16800		MULI A,TEN
16900		PUSHJ P,FP7B
17000		SKIPE B
17100		AOJL T,FP3A
17200		POPJ P,
17300	
17400	FP4:	MOVNI C,6
17500		MOVEI TT,0
17600	FP4A:	ADDI TT,1(TT)
17700		XCT FCP(B)
17800		TRZA TT,1
17900		FMPR A,@FCP+1(B)
18000		AOJN C,FP4A
18100		PUSH P,TT
18200		MOVNI B,-2(B)
18300		DPB B,[POINT 2,FP4C,34]
18400		PUSHJ P,FP3
18500		MOVEI A,"E"
18600		PUSHJ P,(R)
18700		MOVE A,FP4C#
18800		IORI A,51
18900		PUSHJ P,(R)
19000		POP P,A
19100	FP7:	JUMPE A,FP7A1
19200		IDIVI A,TEN
19300		AOS FPTEM
19400		HRLM B,(P)
19500		JUMPE A,FP7A1
19600		PUSHJ P,FP7
19700	
19800	FP7A1:	HLRE A,(P)
19900	FP7B:	ADDI A,"0"
20000		JRST (R)
20100	
20200		353473426555	;1e32
20300		266434157116	;1e16
20400	FT8:	1.0E8
20500		1.0E4
20600		1.0E2
20700		1.0E1
20800	FT:	1.0E0
20900		026637304365	;1e-32
21000		113715126246	;1e-16
21100		146527461671	;1e-8
21200		163643334273	;1e-4
21300		172507534122	;1e-2
21400	FT01:	175631463146	;1e-1
21500	FT0:
21600	FCP:	CAMLE A,FT0(C)
21700			CAMGE A,FT(C)
21800		XWD C,FT0
21900	
     

00100			SUBTTL SUPER FAST TABLE DRIVEN READ 	14-MAY-69      PAGE 9
00200	
00300	;magic scanner table bit definitions
00400	
00500	;bit 0=0 iff slashified as nth id character
00600	;bit 1=0 iff slashified as 1st id character
00700	;bits 2-5	ratab index
00800	;bits 6-8	dotab index
00900	;bits 9-10	strtab index
01000	;bits 11-13	idtab index
01100	;bits 14-16	exptab index
01200	;bits 17-19	rdtab index
01300	;bits 20-25	ascii to radix 50 conversion
01400	
01500	REMOTE<
01600	IGSTRT:	IGCRLF
01700	IGEND:	LF
01800	
01900	RATFLD:	POINT 4,CHRTAB(A),5
02000	STRFLD:	POINT 2,CHRTAB(A),10
02100	IDFLD:	POINT 3,CHRTAB(A),13
02200	>
02300	DOTFLD:
02400	NUMFLD:	POINT 3,CHRTAB(A),8
02500	EXPFLD:	POINT 3,CHRTAB(A),16
02600	RDFLD:	POINT 3,CHRTAB(A),19
02700	R50FLD:	POINT 6,CHRTAB(A),25
02800	
02900	;magic state flags in t
03000	EXP==1		;exponent 
03100	NEXP==2		;negative exponent
03200	SAWDOT==4	;saw a dot (.)
03300	MINSGN==10	;negative number
03400	
03500	IDCLS==0	;identifier
03600	STRCLS==1	;string
03700	NUMCLS==2	;number
03800	DELCLS==3	;delimiter
03900	
04000	PAGE
04100	;macros for scanner table
04200	
04300	DEFINE RAD50 (X)<
04400	IFB <X>,<R50VAL=0>
04500	IFLE <"X"-"9">,<IFGE <"X"-"0">,<R50VAL="X"-"0"+1>>
04600	IFIDN <"X"><".">,<R50VAL=45>
04700	IFGE <"X"-"A">,<R50VAL="X"-"A"+13>>
04800	
04900	DEFINE TABIN (S1,SN,R,D,S,I,E,RD,R50)<
05000	XLIST
05100	IRPC R50<	RAD50 (R50)
05200		BYTE (1)S1,SN(4)R(3)D(2)S(3)I,E,RD(6)R50VAL>
05300	LIST>
05400	
05500	DEFINE LET (X)<
05600	TABIN (1,1,5,2,3,4,2,0,X)>
05700	
05800	DEFINE DELIMIT (X,Y)<
05900	TABIN (0,0,2,2,3,2,2,Y,X)>
06000	
06100	DEFINE IGNORE (X)<
06200	TABIN (0,0,3,2,3,2,2,0,X)>
06300	PAGE
06400	REMOTE<CHRTAB:
06500	TABIN (0,0,1,1,1,1,1,0,< >)	
06600	;null
06700	LET (<        >)
06800	IGNORE (<     >)		
06900	;tab,lf,vtab,ff,cr
07000	LET (<           >)	
07100	;16 to 30
07200	TABIN (0,0,0,0,0,0,0,0,< >)
07300	;igmrk
07400	TABIN (0,0,0,0,0,0,0,0,< >)
07500	;32 THE OLD IGMRK, WILL ALLOW THE CHAR. TO WORK ON READS BUT NOT TYI
07600	LET (<     >)
07700	;33 to 37
07800	IGNORE (< >)			
07900	;space
08000	LET (< >)			
08100	;!
08200	TABIN (0,0,9,2,2,2,2,0,< >)	
08300	;"
08400	LET (< $%  >)			
08500	;#$%&'
08600	DELIMIT (< >,0)
08700	DELIMIT (< >,1)
08800	;()
08900	LET (< >)			
09000	;*
09100	TABIN (1,1,14,2,3,4,2,0,< >)	
09200	;+
09300	IGNORE (< >)			
09400	;,
09500	TABIN (1,1,6,2,3,4,2,0,< >)	
09600	;-
09700	TABIN (0,0,7,3,3,2,2,4,<.>)
09800	TABIN (0,0,4,2,3,3,2,0,< >)	
09900	;/
10000	TABIN (1,0,8,5,3,4,3,0,<0123456789>)
10100	LET (<      >)			
10200	;:;<=>?
10300	TABIN (1,0,2,2,3,4,2,5,< >)	
10400	;@
10500	LET (<ABCD>)
10600	TABIN (1,1,5,4,3,4,2,0,<E>)
10700	LET (<FGHIJKLMNOPQRSTUVWXYZ>)
10800	DELIMIT (< >,2)			
10900	;[
11000	LET (< >)			
11100	;\
11200	DELIMIT (< >,3)			
11300	;]
11400	LET (<   >)			
11500	;↑←`
11600	LET (<ABCDEFGHIJKLMNOPQRSTUVWXYZ>)	
11700	;lower case
11800	LET (<  >)			
11900	;{¬
12000	DELIMIT (< >,3)			
12100	;altmode
12200		LET (< >)
12300	;}
12400	DELIMIT (< >,6)			
12500	;rubout
12600	>
12700	PAGE
12800	READCH:	PUSHJ P,TYI
12900		MOVSI AR1,AR1
13000		PUSHJ P,EXPL1
13100		JRST CAR
13200	
13300	READP1:	SETZM NOINFG
13400	READ0:	PUSH P,TYI2
13500		PUSH P,OLDCH
13600		SETZM OLDCH#
13700		HRLI A,(JRST)
13800		MOVEM A,TYI2
13900		PUSHJ P,READ+1
14000		POP P,OLDCH
14100		POP P,TYI2
14200		POPJ P,
14300	
14400	RDRUB:	MOVEI A,CR
14500		PUSHJ P,TTYO
14600		MOVEI A,LF
14700		PUSHJ P,TTYO
14800		SKIPA P,PSAV#
14900	READ:	SETZM NOINFG#	;0 means intern
15000		MOVEM P,PSAV
15100		PUSHJ P,READ1
15200		SETZM PSAV
15300		POPJ P,
15400	
15500	READ1:	PUSHJ P,RATOM
15600		POPJ P,		;atom
15700		XCT RDTAB2(B)
15800		JRST READ1	;try again
15900	
16000	RDTAB2:	JRST READ2	;0	(
16100		JFCL		;1	)
16200		JRST READ4	;2	[
16300		JFCL		;3	],$
16400		JFCL		;4	.
16500		JRST RDQT	;5	@
16600	
16700	READ2:	PUSHJ P,RATOM
16800		JRST READ2A	;atom
16900		XCT RDTAB(B)
17000	
17100	READ2A:	PUSH P,A
17200		PUSHJ P,READ2
17300		POP P,B
17400		JRST XCONS
17500	
17600	RDTAB:	PUSHJ P,READ2	;0	(
17700		JRST FALSE	;1	)
17800		PUSHJ P,READ4	;2	[
17900		JRST READ5	;3	],$
18000		JRST RDT	;4	.
18100		PUSHJ P,RDQT	;5	@
18200	
18300	RDTX:	PUSHJ P,RATOM
18400		POPJ P,	;atom
18500		XCT RDTAB2(B)
18600		JRST DOTERR	;dot context error
18700	
18800	RDT:	PUSHJ P,RDTX
18900		PUSH P,A
19000		PUSHJ P,RATOM
19100		JRST DOTERR
19200		CAIN B,1
19300		JRST POPAJ
19400		CAIE B,3
19500		JRST DOTERR
19600		MOVEM A,OLDCH
19700		JRST POPAJ
19800	
19900	
20000	READ4:	PUSHJ P,READ2
20100		MOVE B,OLDCH
20200		CAIE B,ALTMOD
20300	TYI1:	SETZM OLDCH	;kill the ]
20400		POPJ P,
20500	
20600	READ5:	MOVEM A,OLDCH	;save ] or $
20700		JRST FALSE	;and return nil
20800	
20900	
21000	RDQT:	PUSHJ P,READ1
21100		JRST QTIFY
21200	PAGE
21300	;atom parser
21400	
21500	COMMENT:	PUSHJ P,TYID
21600		CAME A,IGEND
21700		JRST COMMENT
21800		POPJ P,
21900	
22000	RATOM:	SKIPE SMAC#	;$$ CHECK FOR A SPLICE MACRO LIST
22100		JRST PSMAC	;$$ GET ITEM FROM SPLICE MACRO LIST
22200		SETZB T,R
22300		HRLI C,(POINT 7,0,35)
22400		HRRI C,(SP)
22500		MOVEM C,ORGSTK#		;SAVE FOR BACKING UP ON + AND -
22600		MOVEI AR1,1
22700	RATOM2:	PUSHJ P,TYIA
22800		LDB B,RATFLD
22900		JRST RATAB(B)
23000	
23100	RATAB:	PUSHJ P,COMMENT	;0	comment
23200		JRST RATOM2	;1	null
23300		JRST RATOM3	;2	delimit
23400		JRST RATOM2	;3	ignore
23500		PUSHJ P,TYI	;4	/
23600		JRST RDID	;5	letter
23700		JRST RDNMIN	;6	-
23800		JRST RDOT	;7	.
23900		JRST RDNUM	;8	digit
24000		JRST RDSTR	;9	string
24100		JRST RMACRO	;10	MACRO
24200		JRST SMACRO	;11	SPLICE MACRO
24300		JRST RDNPLS	;12	+
24400	
24500	;a real dotted pair
24600	RDOT2:	MOVEM A,OLDCH
24700		MOVE A,ORGSGN	;ORGSGN NORMALLY CONTAINS A "." AT THIS POINT
24800	RATOM3:	LDB B,RDFLD
24900		HRRI R,DELCLS	;delimiter
25000		AOS (P)		;non-atom (ie a delimiter)
25100		POPJ P,
25200	
25300	;dot handler
25400	RDOT:	MOVEM A,ORGSGN	;INCASE SOMETHING ELSE DEFINED AS "."
25500		PUSHJ P,TYID
25600		LDB B,DOTFLD
25700		JRST DOTAB(B)
25800	
25900	DOTAB:	PUSHJ P,COMMENT	;0	comment
26000		JRST RDOT+1	;1	null
26100		JRST RDOT2	;2	delimit
26200		JRST RDOT2	;3	dot
26300		JRST RDOT2	;4	e
26400		MOVEI B,0	;5	digit
26500		IDPB B,C
26600		TLO T,SAWDOT
26700		JRST RDNUM
26800	PAGE
26900	;string scanner
27000	STRTAB:	PUSHJ P,COMMENT	;0	comment
27100		JRST RDSTR+1	;1	null
27200		JRST STR2	;2	delimit
27300	RDSTR:	IDPB A,C	;3	string element
27400		PUSHJ P,TYID
27500		LDB B,STRFLD
27600		JRST STRTAB(B)
27700	
27800	STR2:	MOVEI A,DBLQT
27900		HRRI R,STRCLS	;string
28000		IDPB A,C
28100	NOINTR:	PUSHJ P,IDEND	;no intern
28200		PUSHJ P,IDSUB
28300		JRST PNAMAK
28400	
28500	
28600	;identifier scanner
28700	IDTAB:	PUSHJ P,COMMENT	;0	
28800		JRST RDID+1	;1	null
28900			JRST MAKID	;2	delimit
29000		PUSHJ P,TYI	;3	/
29100	RDID:	IDPB A,C	;4	letter or digit
29200		PUSHJ P,TYID
29300		LDB B,IDFLD	
29400		JRST IDTAB(B)
29500	PAGE
29600	;LINEREAD - RETURNS ALL THE EXPRESSIONS ON ONE LINE AS A LIST
29700	;
29800	LINRD:	PUSHJ	P,READ
29900		HRRZ	B,A
30000		SKIPE	SMAC		;CHECK THE SPLICE LIST
30100		JRST	LRMORE
30200		SKIPN	A,OLDCH
30300	LRTY:	PUSHJ	P,TYID		;NEED A CHARACTER
30400		MOVEM	A,OLDCH		;SAVE IT
30500		LDB	C,RATFLD	;THIS KLUDGE IS TO AVOID MAKING ANOTHER TABLE ENTRY
30600		CAIN	C,7		;SPECIAL CHECK FOR "."
30700		JRST	LRTY1		;IGNORE IT
30800		CAILE	C,3		;ELIMINATE MOST POSSIBILITIES
30900		JRST	LRMORE		;MORE ON THE LINE
31000		JUMPE	C,LREND		;END LINE ON COMMENT - THINK ABOUT IT, ITS RIGHT
31100		LDB	C,RDFLD
31200		JRST	LR1(C)
31300	LR1:	JRST	LPIG		;0	MORE TO FIGURE OUT
31400		JRST	LRTY1		;1	IGNORE
31500		JRST	LRMORE		;2	MORE ON THE LINE
31600		SUBI	A,ALTMOD	;3	CHECK ALTMOD
31700		JUMPN	A,LRTY1		;4	IGNORE "]" AND "."
31800		JUMPN	A,LRMORE	;5	MORE ON "@"
31900		JRST	LREND
32000	LPIG:	CAIN	A,"("		;THESE SPECIAL CHECK COULD SCREW UP READ MACROS
32100		JRST	LRMORE
32200		CAIE	A,TAB
32300		CAIL	A,40		;READ MORE IF SPACE, COMMA, OR TAB
32400		JRST [	HRLI B,-1	;SET SPQCE FLAG AND TRY AGAIN
32500			JRST LRTY]
32600		CAIE	A,CR		;ALWAYS IGNORE CR.S
32700		TLZE	B,-1		;EOL - IF SPACE FLAG THEN DO A PEEKC
32800		JRST	LRTY
32900	LREND:	HRRZ	A,B		;FINALLY GOT THERE
33000		JRST	NCONS
33100	LRMORE:	HRLI	B,0
33200		PUSH	P,B		;MORE TO GO, PUSH
33300		PUSHJ	P,LINRD		;AND CALL YOURSELF
33400		POP	P,B
33500		JRST	XCONS
33600	LRTY1:	HRLI	B,0		;CLEAR SPACE FLAG
33700		JRST	LRTY
33800	
33900	PAGE
34000	;NEW AND SUBER BITCHEN READ MACROS
34100	;
34200	RMACRO:
34300		IFN ALVINE,<
34400		SKIPE PSAV1	;$$ ARE WE IN ALVINE?
34500		JRST RATOM2	;$$ YES, IGNORE>
34600	RMAC2:	IDPB A,C	;$$ CONVERT THE CHAR. TO AN ATOM
34700		PUSHJ P,IDEND	;$$
34800		PUSHJ P,INTER0	;$$
34900		MOVEM A,T	;$$ SAVE ATOM IN CASE OF ERROR
35000		MOVEI B,READMACRO(S)	;$$ GET THE FUNCTION NAME
35100		PUSHJ P,GET	;$$
35200		JUMPE A,RMERR	;$$ UNDEFINED READ MACRO
35300		PUSHJ P,NCONS	;$$ CONVERT TO A FORM
35400		PUSH P,PSAV	;$$
35500		PUSHJ P,EVAL	;$$ EVALUATE THE FORM
35600		POP P,PSAV	;$$
35700		POPJ P,	;$$ RETURN
35800	
35900	;SPECIAL PROCESSING OF SPLICE MACROS
36000	SMACRO:
36100	IFN ALVINE,<
36200		SKIPE PSAV1	;$$ ARE WE IN ALVINE?
36300		JRST RATOM2	;$$ YES, IGNORE>
36400		PUSHJ P,RMAC2	;$$ EVALUATE THE MACRO
36500		MOVEM A,SMAC	;$$ SAVE THE SPLICE LIST
36600		JRST RATOM	;$$ START OVER
36700	
36800	;GET AN ITEM OFF OF THE SPLICE LIST
36900	PSMAC:	MOVE A,SMAC	;$$
37000		PUSHJ P,ATOM	;$$ IS SPLICE LIST AN ATOM?
37100		JUMPN A,[	MOVE A,SMAC	;$$ YES, SIMULATE . <ATOM>
37200				PUSHJ P,NCONS	;$$
37300				MOVEM A,SMAC	;$$
37400				MOVEI B,4	;$$
37500				JRST RATOM3+1]	;$$
37600		MOVE B,@SMAC	;$$
37700		HLRZ A,B	;$$ RETURN NEXT ITEM OF SPLICE LIST
37800		HRRZM B,SMAC	;$$ ADVANCE SPLICE LIST
37900		POPJ P,	;$$ RETURN
38000		PAGE
38100	;number scanner
38200	NUMTAB:	PUSHJ P,COMMENT	;0	comment
38300		JRST RDNUM+1	;1	null
38400		JRST NUMAK	;2	delimit
38500		JRST RDNDOT	;3	dot
38600		JRST RDE	;4	e
38700	RDNUM:	IDPB A,C	;5	digit
38800		PUSHJ P,TYID
38900		LDB B,NUMFLD
39000		JRST NUMTAB(B)
39100	
39200	RDNDOT:	TLOE T,SAWDOT
39300		JRST NUMAK	;two dots - delimit
39400		MOVEI A,0
39500		JRST RDNUM
39600	
39700	RDNMIN:	TLO T,MINSGN
39800	RDNPLS:	MOVEM A,ORGSGN#		;SAVE SIGN IN CASE OF BACKUP
39900		JRST RDNUM+1
40000	
40100	;exponent scanner
40200	RDE:	CAME	C,ORGSTK	;FOR +E AND -E TYPE OF ATOMS
40300		JRST	.+3
40400		MOVEM	A,OLDCH
40500		JRST	KLDG1
40600		TLO T,EXP
40700		MOVEI A,0
40800		IDPB A,C
40900		PUSHJ P,TYID
41000		CAIN A,"-"
41100		TLOA T,NEXP
41200		CAIN A,"+"
41300		JRST RDE2+1
41400		JRST RDE2+2
41500	
41600	EXPTAB:	PUSHJ P,COMMENT	;0
41700		JRST RDE2+1	;1	null
41800		JRST NUMAK	;2	delimit
41900	RDE2:	IDPB A,C	;3	digit
42000		PUSHJ P,TYID
42100		LDB B,EXPFLD
42200		JRST EXPTAB(B)
42300	PAGE
42400	;semantic routines
42500	;identifier interner and builder
42600	
42700	IDEND:	TDZA A,A
42800	IDEND1:	IDPB A,C
42900		TLNE C,760000
43000		JRST IDEND1 
43100		POPJ P,
43200	
43300	MAKID:	MOVEM A,OLDCH
43400		PUSHJ P,IDEND
43500		SKIPE NOINFG
43600		JRST NOINTR	;dont intern it
43700	INTER0:	PUSHJ P,IDSUB
43800		PUSHJ P,INTER1	;is it in oblist
43900		POPJ P,		;found
44000		PUSHJ P,PNAMAK	;not there
44100	MAKID2:	MOVE C,CURBUC#	;
44200		HLRZ B,@RHX2
44300		PUSHJ P,CONS	;cons it into the oblist
44400		HRLM A,@RHX2
44500		JRST CAR
44600	
44700	;pname unmaker
44800	PNAMUK:
44900		MOVEI B,PNAME(S)
45000		PUSHJ P,GET
45100		JUMPE A,NOPNAM
45200		MOVE C,SP
45300	PNAMU3:	HLRZ B,(A)
45400		PUSH C,(B)
45500		HRRZ A,(A)
45600		JUMPN A,PNAMU3 
45700		POPJ P,
45800	
45900	;idsub constructs a iowd pointer for a print name
46000	IDSUB:	HRRZS C
46100		CAML C,JRELO	;top of spec pdl
46200		JRST SPDLOV
46300		MOVNS C
46400		ADDI C,(SP)
46500		HRLI C,1(SP)
46600		MOVSM C,IDPTR#
46700		POPJ P,
46800	
46900	PAGE		;identifier interner
47000	INTER1:	MOVE B,1(SP)	;get first word of pname 
47100		LSH B,-1	;right justify it 
47200		IDIV B,INT1	;compute hash code 
47300	REMOTE<
47400	INT1:	BCKETS
47500	RHX2:
47600	XXX1:	XWD B+1,OBTBL>
47700		HLRZ TT,@RHX2	;get bucket 
47800		MOVEM B+1,CURBUC	;save bucket number 
47900		MOVE T,TT 
48000		JRST MAKID1
48100	
48200	MAKID3:	MOVE TT,T	;save previous atom 
48300		HRRZ T,(T)	;get next atom 
48400	MAKID1:	JUMPE T,CPOPJ1	;not in oblist
48500		HLRZ A,(T)	;next id in oblist
48600	MAKID4:	HRRZ A,(A)
48700		JUMPE A,NOPNAM	;no print name
48800		MOVE A,(A)
48900		HLRZ C,A
49000		CAIE C,PNAME(S)
49100		JRST MAKID4
49200		MOVE C,IDPTR	;found pname
49300		HLRZ A,(A)
49400	MAKID5:	JUMPE A,MAKID3	;not the one
49500		MOVS A,(A)
49600		MOVE B,(A)
49700		ANDCAM AR1,(C)	;clear low bit
49800		CAME B,(C)
49900		JRST MAKID3	;not the one
50000		HLRZ A,A	;ok so far
50100		AOBJN C,MAKID5
50200		JUMPN A,MAKID3	;not the one
50300		HLRZ A,(T)	;this is it
50400		HLRZ B,(TT) 
50500		HRLM A,(TT) 
50600		HRLM B,(T) 
50700		POPJ P,
50800	
50900	;pname builder
51000	PNAMAK:	MOVE T,IDPTR
51100		PUSHJ P,NCONS
51200		MOVE TT,A
51300		MOVE C,A
51400	PNAMB:	MOVE A,(T)
51500		TRZ A,1		;clear low bit!!!!!
51600		PUSHJ P,FWCONS
51700		PUSHJ P,NCONS
51800		HRRM A,(TT)
51900		MOVE TT,A
52000		AOBJN T,PNAMB
52100		MOVE A,C
52200		HRLZS (A)
52300		JRST PNGNK1+1
52400	PAGE
52500	;number builder
52600	NUMAK:	MOVEM A,OLDCH
52700		HRRI R,NUMCLS	;number
52800		CAME C,ORGSTK	;BIG KLUDGE FOR + AND -
52900		JRST .+5
53000	KLDG1:	MOVE A,ORGSGN	;ENTER HERE TO BACK UP IN THE CASE OF +E OR -E
53100		IDPB A,C
53200		PUSHJ P,TYIA
53300		JRST RDID+2
53400		MOVEI A,0
53500		IDPB A,C
53600		IDPB A,C
53700		HRRZS C
53800		CAML C,JRELO	;top of spec pdl
53900		JRST SPDLOV
54000		MOVSI C,(POINT 7,0,35)
54100		HRRI C,(SP)
54200		TLNE T,SAWDOT+EXP
54300		JRST NUMAK2	;decimal number or flt pt
54400		MOVE A,VIBASE(S)	;ibase integrer
54500		SUBI A,INUM0
54600		PUSHJ P,NUM
54700	NUMAK4:
54800		MOVEI B,FIXNUM(S)
54900	NUMAK6:	TLNE T,MINSGN
55000		MOVNS A
55100		JRST MAKNUM
55200	
55300	NUMAK2:	PUSHJ P,NUM10
55400		MOVEM A,TT
55500		TLNN T,SAWDOT
55600		JRST [	PUSHJ P,FLOAT	;flt pt without fraction
55700			MOVE TT,A
55800			JRST NUMAK3]
55900		PUSHJ P,NUM10	;fraction part
56000		EXCH A,TT
56100		TLNN T,EXP
56200		JUMPE AR2A,NUMAK4	;no exponent and no fraction
56300		PUSHJ P,FLOAT
56400		EXCH A,TT
56500		PUSHJ P,FLOAT
56600		MOVEI AR1,FT01
56700		PUSHJ P,FLOSUB
56800		FMPR A,B
56900		FADRM A,TT
57000	NUMAK3:	PUSHJ P,NUM10	;exponent part
57100		MOVE AR2A,A
57200		MOVEI AR1,FT-1
57300		TLNE T,NEXP
57400		MOVEI AR1,FT01	;-exponent
57500		PUSHJ P,FLOSUB
57600		FMPR TT,B	;positive exponent
57700		MOVEI B,FLONUM(S)
57800		MOVE A,TT
57900		JFCL 10,FLOOV
58000		JRST NUMAK6
58100	
58200	FLOSUB:	MOVSI B,(1.0)
58300		TRZE AR2A,1
58400		FMPR B,(AR1)
58500		JUMPE AR2A,CPOPJ
58600		LSH AR2A,-1
58700		SOJA AR1,FLOSUB+1
58800	
58900	;variable radix integer builder
59000	
59100	NUM10:	MOVEI A,TEN
59200	NUM:	HRRM A,NUM1
59300		JFCL 10,.+1	;clear carry0 flag 
59400		SETZB A,AR2A
59500	NUM2:	ILDB B,C
59600		JUMPE B,CPOPJ	;done
59700		IMUL A,NUM1#
59800		ADDI A,-"0"(B)
59900	NUM3:	JFCL 10,FIXOV	;bignums change this to jfcl 10,rdbnm
60000		AOJA AR2A,NUM2
60100	PAGE
60200	INTERN:	MOVEM A,AR2A
60300		PUSHJ P,PNAMUK
60400		PUSHJ P,IDSUB
60500		MOVEI AR1,1
60600		PUSHJ P,INTER1		;is it in oblist
60700		POPJ P,			;found it
60800		MOVE A,AR2A		;not there
60900		JRST MAKID2		;put it there
61000	
61100	REMOB:	JUMPE A,FALSE
61200		MOVEI AR1,1
61300		PUSH P,A
61400		HLRZ A,(A)
61500		PUSHJ P,INTERN
61600		HLRZ B,@(P)
61700		CAME A,B
61800		JRST REMOB2
61900		HRRZ B,CURBUC
62000	REMOTE<
62100	RHX5:
62200	XXX2:	XWD B,OBTBL>
62300		HLRZ C,@RHX5
62400		HLRZ T,(C)
62500		CAMN T,A
62600		JRST [	HRRZ TT,(C)
62700			HRLM TT,@RHX5
62800			JRST REMOB2]
62900	REMOB3:	MOVE TT,C
63000		HRRZ C,(C)
63100		HLRZ T,(C)
63200		CAME T,A
63300		JRST REMOB3
63400		HRRZ T,(C)
63500		HRRM T,(TT)
63600	REMOB2:	POP P,A
63700		HRRZ A,(A)
63800		JRST REMOB
63900		PAGE
64000	;ROUTINE TO ALLOW ARBITRARY MODIFICATION AND READING OF THE
64100	;READ CHARACTER-TABLE BY LISP FUNCTIONS
64200	;TAKES TWO ARGUMENTS A,B
64300	;	IF B = NIL IT RETURNS THE CONTENTS OF CHARACTER TABLE
64400	;	LOCATION SPECIFIED BY A
64500	;	OTHERWISE IT CHANGES THE CHARACTER TABLE ENTRY SPECIFIED BY A
64600	;	TO THE BIT PATTERN SPECIFIED BY B, AND RETURNS THE
64700	;	PREVIOUS VALUE
64800	
64900	MODCHR:	PUSH	P,B	;$$SAVE BIT PATTERN FOR TABLE
65000		PUSHJ	P,NUMVAL	;$$GET POSITION IN TABLE
65100		POP	P,B	;$$
65200		MOVE	T,CHRTAB(A)	;$$GET OLD TABLE VALUE
65300		JUMPE	B,MCEXIT	;$$IF B=NIL THEN JUST RETURN OLD TABLE VALUE
65400		PUSH	P,A	;$$SAVE TABLE POSITION
65500	
65600		MOVEI	A,(B)	;$$
65700		PUSHJ	P,NUMVAL	;$$GET NEW BIT PATTERN
65800		POP	P,B	;$$GET TABLE POSITION
65900		MOVEM	A,CHRTAB(B)	;$$CHANGE TABLE
66000	MCEXIT:	MOVE	A,T	;$$RETURN OLD TABLE VALUE
66100		JRST	FIX1A	;$$CONVERT TO BINARY AND EXIT
66200	
66300	;FUNCTION TO DETERMINE THE ASCII VALUE OF A CHARACTER
66400	;	CHRVAL TAKES AN ATOM AS ITS ARGUMENT AND USES THE FIRST
66500	;	CHARACTER OF THE PRINT NAME
66600	CHRVAL:	MOVEI B,PNAME(S)	;$$ GET PRINT NAME
66700		PUSHJ P,GET	;$$
66800		HLRZ A,(A)	;$$
66900		MOVE A,(A)	;$$ FIRST WORD OF PRINT NAME
67000		LSH A,-35	;$$ SHIFT TO GET FIRST CHARACTER
67100		JRST FIX1A	;$$ CONVERT TO INTEGER
67200	
67300	;FUNCTION TO SET BITS FOR A READ MACRO
67400	;	A IS THE CHAR. ATOM AND B ARE THE STATUS BITS,
67500	;	IF B=NIL NO MODIFICATION IS MADE
67600	;	THE OLD STATUS BITS ARE RETURNED
67700	SETCHR:	MOVE TT,B	;$$
67800		PUSHJ P,CHRVAL	;$$ CONVERT CHAR. TO INUM
67900		MOVEI B,-INUM0(A)	;$$ CONVERT INUM TO BINARY
68000		LDB A,[POINT 5,CHRTAB(B),5]	;$$ LOAD OLD BITS
68100		JUMPE TT,FIX1A	;$$ NO CHANGE IF B = NIL
68200		MOVEI TT,-INUM0(TT)	;$$ CONVERT STATUS TO BINARY
68300		DPB TT,[POINT 5,CHRTAB(B),5]	;$$ SET NEW BITS
68400		JRST FIX1A	;$$ RETURN
68500	
68600	
68700			SUBTTL LISP INTERPRETER SUBROUTINES   --- PAGE 10
68800		PAGE
68900	
69000	CADDDR:	SKIPA A,(A)
69100	CADDAR:	HLRZ A,(A)
69200	CADDR:	SKIPA A,(A)
69300	CADAR:	HLRZ A,(A)
69400	CADR:	SKIPA A,(A)
69500	CAAR:	HLRZ A,(A)
69600	CAR:	HLRZ A,(A)
69700		POPJ P,
69800	
69900	CDDDDR:	SKIPA A,(A)
70000	CDDDAR:	HLRZ A,(A)
70100	CDDDR:	SKIPA A,(A)
70200	CDDAR:	HLRZ A,(A)
70300	CDDR:	SKIPA A,(A)
70400	CDAR:	HLRZ A,(A)
70500	CDR:	HRRZ A,(A)
70600		POPJ P,
70700	
70800	CAADDR:	SKIPA A,(A)
70900	CAADAR:	HLRZ A,(A)
71000	CAADR:	SKIPA A,(A)
71100	CAAAR:	HLRZ A,(A)
71200		JRST CAAR
71300	
71400	CDADDR:	SKIPA A,(A)
71500	CDADAR:	HLRZ A,(A)
71600	CDADR:	SKIPA A,(A)
71700	CDAAR:	HLRZ A,(A)
71800		JRST CDAR
71900	
72000	CAAADR:	SKIPA A,(A)
72100	CAAAAR:	HLRZ A,(A)
72200		JRST CAAAR
72300	
72400	CDDADR:	SKIPA A,(A)
72500	CDDAAR:	HLRZ A,(A)
72600		JRST CDDAR
72700	
72800	CDAADR:	SKIPA A,(A)
72900	CDAAAR:	HLRZ A,(A)
73000		JRST CDAAR
73100	
73200	CADADR:	SKIPA A,(A)
73300	CADAAR:	HLRZ A,(A)
73400		JRST CADAR
73500	PAGE
73600	
73700	QUOTE:	HLRZ A,(A)	;car and quote duplicated for backtrace
73800		POPJ P,
73900	
74000	AASCII:	PUSHJ P,NUMVAL
74100		LSH A,↑D29
74200		PUSHJ P,FWCONS
74300		PUSHJ P,NCONS
74400	PNGNK1:	PUSHJ P,NCONS
74500		MOVEI B,PNAME(S)
74600		PUSHJ P,XCONS
74700	ACONS:	TROA B,-1
74800	NCONS:	TRZA B,-1
74900	XCONS:	EXCH B,A
75000	CONS:	AOS CONSVAL
75100		HRL B,A
75200		SKIPN A,F
75300		JRST [	HLR A,B
75400			PUSHJ P,AGC
75500			JRST .-1]
75600		MOVE F,(F)
75700		MOVEM B,(A)
75800		POPJ P,
75900	
76000	;new consing routines-not finished yet
76100	;acons:	troa b,-1
76200	;ncons:	trz b,-1
76300	;cons:	exch b,a
76400	;xcons:	hrl a,b
76500	;	exch a,(f) 
76600	;	exch a,f
76700	;	popj p,
76800	
76900	CONSP:	CAILE A,INUMIN
77000		JRST FALSE
77100		HLLE A,(A)
77200		AOJE A,FALSE
77300		JRST TRUE
77400	PATOM:	CAIL A,@GCP1
77500		JRST TRUE
77600		CAIL A,@GCPP1
77700	ATOM:	CAILE A,INUMIN
77800		JRST TRUE
77900		HLLE A,(A)
78000		AOJE A,TRUE
78100		JRST FALSE
78200	PAGE
78300	NEQ:	CAMN A,B
78400		JRST FALSE
78500		JRST TRUE
78600	EQ:	CAMN A,B
78700		JRST TRUE
78800		JRST FALSE
78900	
79000	LENGTH:	MOVEI B,0
79100	LNGTH1:	CAILE A,INUMIN
79200		JRST FIX1
79300		HLLE C,(A)
79400		AOJE C,FIX1
79500		HRRZ A,(A)
79600		AOJA B,LNGTH1
79700	
79800	LAST:	HRRZ B,(A)
79900		CAILE B,INUMIN
80000		POPJ P,
80100		HLLE B,(B)
80200		AOJE B,CPOPJ
80300		HRRZ A,(A)
80400		JRST LAST
80500	
80600	;(LITATOM X) = (AND (ATOM X) (NOT (NUMBERP X)))
80700	LITATOM:MOVE	B,A
80800		PUSHJ	P,ATOM
80900		JUMPE	A,CPOPJ
81000		MOVE	A,B
81100		PUSHJ	P,NUMBERP
81200		JRST	NOT
81300		PAGE
81400	;NEW RPLACD AND RPLACA WHICH CHECK SO AS NOT TO  CLOBBER NIL AND ATOMS
81500	RPLACA:	CAILE	A,INUMIN	;$$
81600		JRST	RPAERR	;$$ ATTEMPT TO RPLACA A SMALL NUMBER
81700		HLL	A,(A)	;$$TEST FOR OTHER ATOMS
81800		TLC	A,-1	;$$
81900		TLZN	A,-1	;$$ATOM CARS ARE -1
82000		JRST	RPAERR	;$$ATTEMPT TO RPLACA AN ATOM
82100		HRLM	B,(A)	;$$STANDARD CODE FOR RPLACA
82200		POPJ	P,	;$$
82300	
82400	RPLACD:	CAIG	A,INUMIN	;$$CHECK FOR SMALL BER
82500		JUMPN	A,.+2	;$$CHECK FOR NIL
82600		JRST	RPDERR	;$$ATTEMPT TO RPLACD NIL  OR A SMALL NUMBER
82700		HRRM	B,(A)	;$$OLD RPLACD CODE
82800		POPJ	P,	;$$
82900	
83000	ZEROP:	PUSHJ P,NUMVAL
83100	NOT:
83200	NULL:	JUMPN A,FALSE
83300	TRUE:
83400		MOVEI A,TRUTH(S)
83500		POPJ P,
83600	
83700	FW0CNS:	MOVEI A,0
83800	FWCONS:	JUMPN FF,FWC1
83900		EXCH A,FWC0#
84000		PUSHJ P,AGC
84100		EXCH A,FWC0
84200	FWC1:	EXCH A,(FF)
84300		EXCH A,FF
84400		POPJ P,
84500	
84600	PAGE
84700		SASSOC:	PUSHJ P,SAS1
84800		JCALLF 0,(C)
84900		POPJ P,
85000	
85100	SAS0:	HLRZ B,T
85200	SAS1:	JUMPE B,CPOPJ
85300		MOVS T,(B)
85400		MOVS TT,(T)
85500		CAIE A,(TT)
85600		JRST SAS0
85700		HRRZ A,T
85800	CPOPJ1:	AOS (P)
85900		POPJ P,
86000	
86100	ASSOC:	PUSHJ P,SAS1
86200	FALSE:	MOVEI A,NIL
86300	CPOPJ:	POPJ P,
86400	
86500	REVERSE:	MOVE T,A
86600		MOVEI A,0
86700		JUMPE T,CPOPJ
86800		HLRZ B,(T)
86900		HRRZ T,(T)
87000		PUSHJ P,XCONS
87100		JUMPN T,.-3
87200		POPJ P,
87300	
87400	
87500	REMPROP:	HRRZ T,(A)
87600		MOVS TT,(T)
87700		CAIN B,(TT)
87800		JRA TT,REMP1
87900		HLRZ A,TT
88000		HRRZ T,(A)
88100		JUMPN T,REMPROP+1
88200		JRST FALSE
88300	
88400	REMP1:	HRRM TT,(A)
88500		JRST TRUE
88600	PAGE
88700	GET:	HRRZ A,(A)
88800		MOVS D,(A)
88900		CAIN B,(D)
89000		JRST CADR
89100		HLRZ A,D
89200		HRRZ A,(A)
89300		JUMPN A,GET+1
89400		POPJ P,
89500	
89600	GETL:	JUMPE B,FALSE	;$$ NIL LIST - NIL ANSWER
89700		HRRZ A,(A)
89800	GETL0:	HLRZ T,(A)
89900		MOVE C,B
90000	GETL1:	MOVS TT,(C)
90100		CAIN T,(TT)
90200		POPJ P,
90300		HLRZ C,TT
90400		JUMPN C,GETL1
90500		HRRZ A,(A)
90600		HRRZ A,(A)
90700		JUMPN A,GETL0
90800			POPJ P,
90900	
91000	NUMBERP:	CAILE A,INUMIN
91100		JRST TRUE
91200		HLLE T,(A)
91300		AOJN T,FALSE
91400		HRRZ A,(A)
91500		HLRZ A,(A)
91600		CAIE A,FIXNUM(S)
91700		CAIN A,FLONUM(S)
91800		JRST TRUE
91900	NUMBP2:	JRST FALSE	;bignums change this to JRST BIGNP
92000	STRINGP: MOVE	B,A	;= T IF A IS A STRING
92100		PUSHJ	P,ATOM
92200		JUMPE	A,CPOPJ
92300		MOVE	A,B
92400		PUSHJ	P,NUMBERP	;MUST NO BE A NUMBER
92500		JUMPN	A,FALSE
92600		MOVE	A,B
92700		PUSHJ	P,CHRVAL	;GET THE FIRST CHARACTER
92800		CAIE	A,42+INUM0	;CHECK FOR "
92900		JRST	FALSE
93000		JRST	TRUE
93100	PAGE
93200	PUTPROP:	MOVE T,A
93300		HRRZ A,(A)
93400	CSET3:	MOVS TT,(A)
93500		HLRZ A,TT
93600		CAIN C,(TT)
93700		JRST CSET2
93800		HRRZ A,(A)
93900		JUMPN A,CSET3
94000		HRRZ A,(T)
94100		PUSHJ P,XCONS
94200		HRRZ B,C
94300		PUSHJ P,XCONS
94400		HRRM A,(T)
94500		JRST CADR
94600	
94700		CSET2:
94800		CAIE C,VALUE(S)
94900		JRST CSET1
95000		HRRZ T,(B)
95100		HLRZ A,(A)
95200		HRRM T,(A)
95300		JRST PROG2
95400	
95500	CSET1:	HRLM B,(A)
95600	PROG2:	MOVE A,B
95700	PROG1:	POPJ P,
95800	
95900	DEFPROP:	
96000		HRRZ B,(A)
96100		HRRZ C,(B)
96200		HLRZ A,(A)
96300		HLRZ B,(B)
96400		HLRZ C,(C)
96500		PUSH P,A
96600		PUSHJ P,PUTPROP
96700		JRST POPAJ
96800	PAGE
96900	EQUAL:	MOVE C,P
97000	EQUAL1:	CAMN A,B
97100		JRST TRUE
97200		MOVE T,A
97300		MOVE TT,B
97400		PUSHJ P,ATOM
97500		EXCH A,B
97600		PUSHJ P,ATOM
97700		CAMN A,B
97800		JRST EQUAL3
97900	EQUAL4:	MOVE P,C
98000		JRST FALSE
98100	
98200	EQUAL3:	JUMPN A,EQ2
98300		PUSH P,T
98400		PUSH P,TT
98500		HLRZ A,(T)
98600		HLRZ B,(TT)
98700		PUSHJ P,EQUAL1
98800		JUMPE A,EQUAL4
98900		POP P,B
99000		POP P,A
99100		HRRZ A,(A)
99200		HRRZ B,(B)
99300		JRST EQUAL1
99400	
99500	EQ2:	PUSH P,T
99600		MOVE A,T
99700		PUSHJ P,NUMBERP
99800		JUMPE A,EQUAL4
99900		MOVE A,TT
     

00100		PUSHJ P,NUMBERP
00200		JUMPE A,EQUAL4
00300		MOVE A,(P)
00400		MOVEM C,(P)
00500		MOVE B,TT
00600		JSP C,OP
00700		JUMPL COMP3
00800		JUMPL COMP3
00900	
01000	COMP3:	POP P,C
01100		CAME A,TT
01200		JRST EQUAL4
01300		JRST TRUE
01400	PAGE
01500	SUBS5:	HRRZ A,SUBAS
01600		POPJ P,
01700	
01800	SUBST:	MOVEM A,SUBAS#
01900		MOVEM B,SUBBS#
02000	SUBS0A:	MOVE A,SUBAS
02100		MOVE B,SUBBS
02200		PUSH P,C
02300		MOVE A,C
02400		PUSHJ P,EQUAL
02500		POP P,C
02600		JUMPN A,SUBS5
02700		CAILE C,INUMIN
02800		JRST EV6A
02900		HLLE T,(C)
03000		AOJN T,SUBS2
03100	EV6A:	MOVE A,C
03200		POPJ P,
03300	
03400	SUBS2:	PUSH P,C
03500		HLRZ C,(C)
03600		PUSHJ P,SUBS0A
03700		EXCH A,(P)
03800		HRRZ C,(A)
03900		PUSHJ P,SUBS0A
04000		POP P,B
04100		JRST XCONS
04200	
04300	COPY:	MOVEI B,INUM0	;$$ (SUBST 0 0 A)
04400		MOVEI C,INUM0
04500		EXCH A,C
04600		JRST SUBST
04700	
04800	; NTHCHAR = THE BTH CHARACTER OF A.
04900	NTHCHAR:MOVE	T,B
05000		SUBI	T,INUM0
05100		JUMPE	T,FALSE		;FAIL IF = 0
05200		PUSH	P,A
05300		MOVEM	T,ORGSGN
05400		JUMPG	T,NTH3
05500		PUSHJ	P,%FLATSIZEC
05600		MOVEI	T,1-INUM0(A)
05700		ADDB	T,ORGSGN
05800	NTH3:	MOVE	A,(P)
05900		PUSHJ	P,LITATOM
06000		JUMPN	A,NTH4
06100		POP	P,A
06200		HRROI	R,NTH5		;I HOPE THIS IS RIGHT
06300		PUSHJ	P,PRINTA
06400		HLRZ	A,ORGSGN
06500		JRST	NTH6
06600	NTH5:	SOSN	ORGSGN
06700		HRLOM	A,ORGSGN
06800		POPJ	P,
06900	NTH4:	MOVE	T,ORGSGN
07000		POP	P,A
07100		MOVEI	B,PNAME(S)
07200		PUSHJ	P,GET
07300		JUMPE	A,CPOPJ		;FAIL IF NO PRINT NAME
07400	NTH1:	CAIG	T,5
07500		JRST	NTH2
07600		HRRZ	A,(A)
07700		JUMPE	A,FALSE		;FAIL IF NO NTH CHARACTER
07800		SUBI	T,5
07900		JRST	NTH1
08000	NTH2:	HLRZ	A,(A)
08100		IMULI	T,-7
08200		LSH	T,14
08300		ADDI	T,440700
08400		HRL	A,T
08500		LDB	A,A
08600		JUMPE	A,FALSE
08700	NTH6:	PUSHJ	P,AASCII+1	;CONVERT TO AN ATOM
08800		JRST	INTERN		;INTERN IT
08900	PAGE
09000	NCONC:	TDZA R,R
09100	APPEND:	MOVEI R,.APPEND-.NCONC
09200		JUMPE T,FALSE
09300		POP P,B
09400	APP2:	AOJE T,PROG2
09500		POP P,A
09600		PUSHJ P,.NCONC(R)
09700		MOVE B,A
09800		JRST APP2
09900	
10000	.NCONC:	JUMPE A,PROG2
10100		MOVE TT,A
10200		MOVE C,TT
10300		HRRZ TT,(C)
10400		JUMPN TT,.-2
10500		HRRM B,(C)
10600		POPJ P,
10700	
10800	.APPEND:	JUMPE A,PROG2
10900		MOVEI C,AR1
11000		MOVE TT,A
11100	APP1:	HLRZ A,(TT)
11200		PUSH P,B
11300		PUSHJ P,CONS	;saves b
11400		POP P,B
11500			HRRM A,(C)
11600		MOVE C,A
11700		HRRZ TT,(TT)
11800		JUMPN TT,APP1
11900		JRST SUBS4
12000	PAGE
12100	MEMBER:	MOVEM A,SUBAS
12200	MEMB1:	JUMPE B,FALSE
12300		MOVEM B,SUBBS
12400		MOVE A,SUBAS
12500		HLRZ B,(B)
12600		PUSHJ P,EQUAL
12700		JUMPN A,CPOPJ
12800		MOVE B,SUBBS
12900		HRRZ B,(B)
13000		JRST MEMB1
13100	
13200	MEMQ:	JUMPE B,FALSE
13300		MOVS C,(B)
13400		CAIN A,(C)
13500		JRST TRUE
13600		HLRZ B,C
13700		JUMPN B,MEMQ+1
13800		JRST FALSE
13900	
14000	
14100	
14200	;NEW MEM-FUNCTIONS THAT RETURN THE TAIL OF THE LIST STARTING WHERE
14300	;	THE ELEMENT IS FOUND
14400	
14500	MEMBR.:	PUSHJ P,MEMBER
14600		SKIPE A
14700		MOVE A,SUBBS
14800		POPJ P,
14900	
15000	MEMB:	PUSHJ P,MEMQ
15100		SKIPE A
15200		MOVE A,B
15300		POPJ P,
15400	
15500	
15600	;NEW AND AND OR FUNCTIONS (AND#, OR#) THAT RETURN THE EXPRESSION
15700	;	THAT CAUSED THE FUNCTION TO EVALUATE TO TRUE
15800	
15900	AND.:	PUSHJ P,AND
16000		SKIPA
16100	OR.:	PUSHJ P,OR
16200		HRRZ A,2(P)
16300		POPJ P,
16400	
16500	AND:
16600		HRLI A,TRUTH(S)
16700	OR:	HLRZ C,A
16800		PUSH P,C
16900	ANDOR:	HRRZ C,A
17000		JUMPE C,AOEND
17100		MOVSI C,(SKIPE (P))
17200		TLNE A,-1
17300		MOVSI C,(SKIPN (P))
17400		XCT C
17500		JRST AOEND
17600		MOVEM A,(P)
17700		HLRZ A,(A)
17800		PUSHJ P,EVAL
17900		EXCH A,(P)
18000		HRR A,(A)
18100		JRST ANDOR
18200	
18300	AOEND:	POP P,A
18400		SKIPE A
18500		MOVEI A,TRUTH(S)
18600		POPJ P,
18700	GENSYM:	MOVE B,[POINT 7,GNUM,34]
18800		MOVNI C,4
18900		MOVEI TT,"0"
19000	
19100	GENSY2:	LDB T,B
19200		AOS T
19300		DPB T,B
19400		CAIG T,"9"
19500		JRST GENSY1
19600		DPB TT,B
19700		ADD B,[XWD 70000,0]
19800		AOJN C,GENSY2
19900	
20000	GENSY1:	MOVE A,GNUM
20100		PUSHJ P,FWCONS
20200		PUSHJ P,NCONS
20300		JRST PNGNK1
20400	
20500	REMOTE<
20600	GNUM:	ASCII /G0000/>
20700	
20800	CSYM:	HLRZ A,(A)
20900		PUSH P,A
21000		MOVEI B,PNAME(S)
21100		PUSHJ P,GET
21200		JUMPE A,NOPNAM
21300		HLRZ A,(A)
21400		MOVE A,(A)
21500		MOVEM A,GNUM
21600		JRST POPAJ
21700	PAGE
21800	LIST:	MOVEI B,CEVAL(S)
21900		PUSH P,B
22000		PUSH P,A
22100		MOVNI T,2
22200		JRST MAPCAR
22300	
22400	EELS:	HLRZ TT,(T)	;interpret lsubr call
22500		HRRZ A,(AR1)
22600	ILIST:	MOVEI T,0
22700		JUMPE A,ILIST2
22800	ILIST1:	PUSH P,A
22900		HLRZ A,(A)
23000		PUSH P,TT
23100		HRLM T,(P)
23200		PUSH	P,SP	;$$SAVE SP POINTER TO RESTORE AFTER ARGUMENT EVALUATED
23300		PUSHJ	P,EVAL	;EVALUATE ARGUMENT
23400		POP	P,SP	;$$RESTORE SP POINTER AFTER EVAL
23500	ILIST3:	POP P,TT
23600		HLRE T,TT
23700		EXCH A,(P)
23800		HRRZ A,(A)
23900		SOS T
24000		JUMPN A,ILIST1
24100	ILIST2:	JRST (TT)
24200	
24300	;FAST MAPC FOR 2 ARGS - CALLED BY LAP CODE ONLY
24400	.MAPC:	PUSH	P,A
24500		JUMPE	B,PRETB
24600		HLRZ	A,(B)
24700		HRRZ	B,(B)
24800		PUSH	P,B
24900		CALLF	1,@-1(P)
25000		POP	P,B
25100		JRST	.MAPC+1
25200	
25300	;FAST MAP FOR 2 ARGS - CALLED BY LAP CODE ONLY
25400	.MAP:	PUSH	P,A
25500		JUMPE	B,PRETB
25600		MOVE	A,B
25700		HRRZ	B,(B)
25800		PUSH	P,B
25900		CALLF	1,@-1(P)
26000		POP	P,B
26100		JRST	.MAP+1
26200	
26300	PRETB:	SUB	P,[XWD 1,1]
26400		JRST	PROG2
26500		PAGE
26600	; NEW AND SUPER POWERFUL MAP FUNCTIONS
26700	MAPCON:	TLZ	T,100000
26800		JRST	MAPLIST
26900	MAPCAN:	TLZA	T,100000
27000	MAPC:	TLZA	T,400000
27100	MAPCAR:	TLZA	T,400000
27200	MAP:	TLZ	T,200000
27300	; INITIALIZE
27400	MAPLIST:SETCA	T,T
27500		MOVEI	A,(CALLF)
27600		DPB	T,[POINT 4,A,30]
27700		MOVE	B,P
27800		MOVE	AR1,T
27900		HRL	AR1,T
28000		SUB	B,AR1
28100		PUSH	P,B
28200		HRLM	A,(B)
28300		PUSH	P,T
28400		PUSH	P,
28500		HRLZM	P,(P)
28600	; SET UP TO GET ARGUMENTS
28700	MAPL2:	HRRZ	T,-1(P)
28800		MOVEI	TT,-3(P)
28900	; MOVE ARGS TO REGS
29000	MPL3:	MOVE	D,(TT)
29100		JUMPE	D,MPDN
29200		MOVEM	D,(T)
29300		MOVE	D,(D)
29400		SKIPGE	-1(P)
29500		HLRZM	D,(T)
29600		HRRZM	D,(TT)
29700		SUBI	TT,1
29800		SOJG	T,MPL3
29900		XCT	(TT)	; CALL THE FUNCTION
30000		LDB	C,[POINT 2,-1(P),2]
30100		TRNE	C,2
30200		JRST	MAPL2
30300	; ATTACH TO OUTPUT LIST
30400		SKIPN	C
30500		PUSHJ	P,NCONS
30600		JUMPE A,MAPL2
30700		HLR	B,(P)
30800		HRRM	A,(B)
30900		SKIPE	C
31000		PUSHJ	P,LAST
31100		HRLM	A,(P)
31200		JRST	MAPL2
31300	; POP STACK AND RETURN
31400	MPDN:	POP	P,AR1
31500		MOVE	P,-1(P)
31600		POP	P,B
31700	SUBS4:	HRRZ	A,AR1
31800		POPJ	P,
31900	;PA3:	0	;THE REG. PDL POINTER
32000	;PA4:	0	;Lh=pntr to prog less bound var list	
32100			;RH=NEXT PROG STATEMENT
32200	
32300	PROG:	PUSH P,PA3#
32400		PUSH P,PA4#
32500		HLRZ TT,(A)
32600		HRRZ A,(A)
32700		HRRM A,PA4
32800		HRLM A,PA4
32900	
33000		MOVE T,SP	;$$ADJUST SPDLSAV POINTER TO INCLUDE EVAL BLIP
33100		SUB T,[XWD 2,2]	;$$SO PA3,PA4 CAN BE RESTORED
33200		MOVEM	T,SPSV#	;$$BY UNBIND
33300		JRST	PG7B	;$$GO CHECK IF ANY VARIABLES TO BIND
33400	
33500	PG7A:	HLRZ A,(TT)
33600		MOVEI AR1,0
33700		PUSHJ P,BIND
33800		HRRZ TT,(TT)
33900	PG7B:	JUMPN TT,PG7A
34000		PUSH SP,SPSV
34100		MOVEM P,PA3
34200	
34300	PG1:	HRRZ T,PA4
34400		JUMPE T,PG4
34500		HLRZ A,(T)
34600		HRRZ T,(T)
34700		HLLE B,(A)
34800		AOJE B,PG1+1
34900		HRRM T,PA4
35000	
35100		PUSH P,SP	;$$SAVE SPDL TO RESTORE AFTER EVAL
35200		PUSHJ P,EVAL
35300		POP P,SP	;$$RESTORE SPDL AFTER EVAL
35400	
35500		JRST PG1
35600	
35700	PGO:	SKIPN	PA3
35800		JRST	EG2
35900		MOVE	P,PA3
36000		MOVE	B,1(P)
36100		PUSHJ	P,UBD
36200		HLRZ	T,PA4
36300	PG5:	JUMPE T,EG1
36400		HLRZ TT,(T)
36500		HRRZ T,(T)
36600		CAIN TT,(A)
36700		JRST PG1+1	;FOUND TAG
36800		JRST PG5
36900		
37000	RETURN:	SKIPN PA3
37100		JRST EG3
37200		MOVE P,PA3
37300		MOVE B,1(P)
37400		PUSHJ P,UBD
37500		JRST PG4+1
37600	PG4:	SETZ A,
37700		PUSHJ P,UNBIND
37800	ERRP4:	POP P,PA4
37900		POP P,PA3
38000		POPJ P,
38100	
38200	GO:	HLRZ A,(A)
38300		HLLE B,(A)
38400		AOJE B,PGO
38500		PUSHJ P,EVAL
38600		JRST GO+1
38700	
38800	
38900	SETQ:	HLRZ B,(A)
39000		PUSH P,B
39100		PUSHJ P,CADR
39200		PUSHJ P,EVAL
39300		MOVE B,A
39400		POP P,A
39500	SET:	SKIPE	A		;$$ MUST BE NON-NIL
39600		CAILE	A,INUMIN	;$$ AND NOT AN INUM
39700		JRST	SETERR		;$$
39800		HLRE	AR1,(A)		;$$ AND AN ATOM
39900		AOJN	AR1,SETERR	;$$
40000		MOVE AR1,B
40100		PUSHJ P,BIND
40200		SUB SP,[XWD 1,1]
40300		MOVE A,AR1
40400		POPJ P,
40500	
40600	CON2:	HRRZ A,(T)
40700	COND:	JUMPE A,CPOPJ	;entry
40800		PUSH P,A
40900		HLRZ A,(A)
41000		HLRZ A,(A)
41100		PUSHJ P,EVAL
41200		POP P,T
41300		JUMPE A,CON2
41400		HLRZ T,(T)
41500	COND2:	HRRZ T,(T)
41600		JUMPE T,CPOPJ	;ENTRY FOR ALL TYPES OF PROGN'S
41700		HLRZ A,(T)
41800		HRRZ T,(T)	;$$
41900		JUMPE T,EVAL	;$$ SAVE STACK SPACE IF NO IMPLIED PROG
42000		PUSH P,T	;$$
42100		PUSHJ P,EVAL
42200		POP P,T
42300		JRST COND2+2	;$$ BECAUSE OF THE LAST CHANGE
42400	
42500	
42600	;LEXORDER - TRUE IF A IS ALPHAMERICALLY LESS THAT OR EQUAL TO B
42700	
42800	LEXORD:	MOVE TT,A
42900		PUSHJ P,NUMBERP
43000		JUMPN A,LEX2	;1ST ARG IS A NUMBER
43100		MOVE A,B
43200		PUSHJ P,NUMBERP
43300		EXCH A,TT
43400		JUMPN TT,FALSE	;1ST=NOT-NUM, 2ND=NUM, DEFINE AS NIL
43500		MOVE T,B
43600		MOVEI B,PNAME(S)
43700		PUSHJ P,GET
43800		EXCH A,T
43900		PUSHJ P,GET
44000	LEX1:	JUMPE T,TRUE
44100		JUMPE A,CPOPJ
44200		HLRZ AR1,(A)
44300		MOVE AR1,(AR1)
44400		HLRZ AR2A,(T)
44500		MOVE AR2A,(AR2A)
44600		LSH AR1,-1
44700		LSH AR2A,-1
44800		CAMLE AR1,AR2A
44900		JRST TRUE
45000		CAME AR1,AR2A
45100		JRST FALSE
45200		HRRZ A,(A)
45300		HRRZ T,(T)
45400		JRST LEX1
45500	LEX2:	MOVE A,B
45600		PUSHJ P,NUMBERP
45700		EXCH A,TT
45800		JUMPE TT,TRUE	;1ST=NUM, 2ND=NOT-NUM, DEFINE AS TRUE
45900		PUSHJ P,.GREAT	;BOTH NUMBERS, DO (NOT (*GREAT A B))
46000		JRST NOT
46100	
46200	
46300	PROGN:	MOVE	T,A	;$$ PROGN
46400		MOVEI	A,NIL
46500		JRST	COND2+1	;$$ IMPLIED PROG DOES THE REST
46600	PAGE
46700			SUBTTL ARITHMETIC SUBROUTINES --- PAGE 11
46800	
46900	;macro expander -- (foo a b c) => (*foo (*foo a b) c)
47000	EXPAND:	MOVE C,B
47100		HRRZ A,(A)
47200		PUSHJ P,REVERSE
47300		JRST EXPA1
47400	
47500	EXPN1:	MOVE C,B
47600	EXPA1:	HRRZ T,(A)
47700		HLRZ A,(A)
47800		JUMPE T,CPOPJ
47900		PUSH P,A
48000		MOVE A,T
48100		PUSHJ P,EXPA1
48200		EXCH A,(P)
48300		PUSHJ P,NCONS
48400		POP P,B
48500		PUSHJ P,XCONS
48600		MOVE B,C
48700		JRST XCONS
48800	
48900	PAGE
49000	
49100	ADD1:	CAILE A,INUMIN
49200		CAIL A,-2
49300		SKIPA B,[INUM0+1]
49400		AOJA A,CPOPJ
49500	.PLUS:	JSP C,OP
49600		ADD A,TT
49700		FADR A,TT
49800	
49900	SUB1:	CAILE A,INUMIN+1
50000		SOJA A,CPOPJ
50100		MOVEI B,INUM0+1
50200	.DIF:	JSP C,OP
50300		SUB A,TT
50400		FSBR A,TT
50500	
50600	.TIMES:	JSP C,OP
50700		IMUL A,TT
50800		FMPR A,TT
50900	
51000	.QUO:	CAIN B,INUM0
51100		JRST ZERODIV
51200		JSP C,OP
51300		IDIV A,TT
51400		FDVR A,TT
51500	
51600	.GREAT:	EXCH A,B
51700		JUMPE B,FALSE
51800	.LESS:	JUMPE A,CPOPJ
51900		JSP C,OP
52000		JRST COMP2	;bignums know about me
52100		JRST COMP2
52200	
52300	COMP2:	CAML A,TT
52400		JRST FALSE
52500		JRST TRUE
52600	
52700	.MAX:	MOVEI D,.GREAT
52800		SKIPA
52900	.MIN:	MOVEI D,.LESS
53000		MOVE AR1,A
53100		MOVE AR2A,B
53200		PUSHJ P,(D)
53300		SKIPN A
53400		MOVE AR1,AR2A
53500		MOVE A,AR1
53600		POPJ P,
53700	PAGE
53800	MAKNUM:
53900		CAIN B,FIXNUM(S)
54000		JRST FIX1A
54100	FLO1A:
54200		MOVEI B,FLONUM(S)
54300		PUSHJ P,FWCONS
54400		JRST ACONS-1
54500	
54600	FIX1B:	SUBI A,INUM0
54700		MOVEI B,FIXNUM(S)
54800		PUSHJ P,FWCONS
54900		JRST ACONS-1
55000	
55100	NUMVLX:	JFCL 17,.+1
55200	NUMVAL:	CAIG A,INUMIN
55300		JRST NUMAG1
55400		SUBI A,INUM0
55500		MOVEI B,FIXNUM(S)
55600		POPJ P,
55700	
55800	NUMAG1:	MOVEM A,AR1
55900		HRRZ A,(A)
56000		HLRZ B,(A)
56100		HRRZ A,(A)
56200		CAIE B,FIXNUM(S)
56300		CAIN B,FLONUM(S)
56400		SKIPA A,(A)
56500	NUMV4:	SKIPA A,AR1
56600		POPJ P,
56700	NUMV2:	PUSHJ P,EPRINT	;bignums know about me
56800		JRST NONNUM
56900	
57000	NUMV3:	JRST NONNUM		;bignums change me to JRST BIGDIS
57100	PAGE
57200	FLOAT:	IDIVI A,400000
57300		SKIPE A
57400		TLC A,254000
57500		TLC B,233000
57600		FADR A,B
57700		POPJ P,
57800	
57900	FIX:	PUSH P,A
58000		PUSHJ P,NUMVAL
58100		CAIE B,FLONUM(S)
58200		JRST POPAJ
58300		MULI A,400
58400		TSC A,A
58500		JFCL 17,.+1
58600		ASH B,-243(A)
58700	FIX2:	JFCL 10,FIXOV	;bignums change me to jfcl 10,bfix
58800		POP P,A
58900	FIX1:	MOVE A,B
59000		JRST FIX1A
59100	
59200	MINUSP:	PUSHJ P,NUMVAL
59300		JUMPGE A,FALSE
59400		JRST TRUE
59500	
59600	MINUS:	PUSHJ P,NUMVLX
59700		MOVNS A
59800		JFCL 10,@OPOV
59900		JRST MAKNUM
60000	
60100	ABS:	PUSHJ P,NUMVLX
60200		MOVMS A
60300		JRST MINUS+2
60400	PAGE
60500	DIVIDE:	CAIN B,INUM0
60600		JRST ZERODIV
60700		JSP C,OP
60800		JUMPN RDIV		;bignums know about me
60900		JRST ILLNUM
61000	RDIV:	IDIV A,TT
61100		PUSH P,B
61200		PUSHJ P,FIX1A
61300		EXCH A,(P)
61400		PUSHJ P,FIX1A
61500		POP P,B
61600		JRST XCONS
61700	
61800	REMAINDER:
61900		PUSHJ P,DIVIDE
62000		JRST CDR
62100	
62200	FIXOV:	ERR1 [SIXBIT /INTEGER OVERFLOW!/]
62300	ZERODIV:ERR1 [SIXBIT /ZERO DIVISOR!/]
62400	FLOOV:	ERR1 [SIXBIT /FLOATING OVERFLOW!/]
62500	ILLNUM:	ERR1 [SIXBIT /NON-INTEGRAL OPERAND!/]
62600	
62700	GCD:	JSP C,OP
62800		JUMPA GCD2	;bignums know about me
62900		JRST ILLNUM
63000	GCD2:	MOVMS A
63100		MOVMS TT
63200	;euclid's algorithm
63300	GCD3:	CAMG A,TT
63400		EXCH A,TT
63500		JUMPE TT,FIX1A
63600		IDIV A,TT
63700		MOVE A,B
63800		JRST GCD3
63900	PAGE
64000	;general arithmetic op code routine for mixed types
64100	
64200	OP:	CAIG A,INUMIN
64300		JRST OPA1
64400		SUBI A,INUM0
64500		CAIG B,INUMIN
64600		JRST OPA2
64700		HRREI TT,-INUM0(B)
64800		XCT (C)	;inum op  (cannot cause overflow)
64900	FIX1A:	ADDI A,INUM0
65000		CAILE A,INUMIN
65100		CAIL A,-1
65200		JRST FIX1B
65300		POPJ P,
65400	
65500	OPA1:	HRRZ A,(A)
65600		HLRZ T,(A)
65700		HRRZ A,(A)
65800		CAIE T,FIXNUM(S)
65900		JRST OPA6
66000		SKIPA A,(A)
66100	OPA2:
66200		MOVEI T,FIXNUM(S)
66300		CAILE B,INUMIN
66400		JRST OPB2
66500		HRRZ B,(B)
66600		HRRZ TT,(B)
66700		HLRZ B,(B)
66800		CAIE B,FIXNUM(S)
66900		JRST OPA5
67000		SKIPA TT,(TT)
67100	OPB2:	HRREI TT,-INUM0(B)
67200		MOVE AR1,A
67300		JFCL 17,.+1
67400		XCT (C)	;fixed pt op
67500		OPOV:	JFCL 10,FIXOV	;bignums change this to jfcl 10,fixovl
67600		JRST FIX1A
67700	
67800	OPA6:	CAILE B,INUMIN
67900		JRST OPB7
68000		HRRZ B,(B)
68100		HRRZ TT,(B)
68200		HLRZ B,(B)
68300		CAIE B,FLONUM(S)
68400		JRST OPB3
68500		CAIE T,FLONUM(S)
68600		JRST NUMV3
68700		MOVE A,(A)
68800		MOVE TT,(TT)
68900	OPR:	JFCL 17,.+1
69000		XCT 1(C)	;flt pt op
69100		JFCL 10,FLOOV
69200		JRST FLO1A
69300	
69400	OPA5:
69500		CAIE B,FLONUM(S)
69600		JRST NUMV3
69700		PUSHJ P,FLOAT
69800		JRST OPR-1
69900	
70000	OPB3:
70100		CAIE B,FIXNUM(S)
70200		JRST NUMV3
70300		SKIPA TT,(TT)
70400	OPB7:	HRREI TT,-INUM0(B)
70500		MOVEI B,FIXNUM(S)
70600		CAIE T,FLONUM(S)
70700		JRST NUMV3
70800		MOVE A,(A)
70900		EXCH A,TT
71000		PUSHJ P,FLOAT
71100		EXCH A,TT
71200		JRST OPR
     

00100			SUBTTL EXPLODE, READLIST AND FRIENDS --- PAGE 12
00200	
00300	%FLATSIZEC:	SKIPA R,.+1	;$$ FLATSIZEC - (LENGTH (EXPLODEC))
00400	FLATSIZE:	HRRZI R,FLAT2
00500		SETZM	FLAT1
00600		PUSHJ P,PRINTA
00700		MOVE	A,FLAT1#
00800		JRST FIX1A
00900	FLAT2:	AOS FLAT1
01000		POPJ P,
01100	
01200	
01300	%EXPLODE:	SKIPA R,.+1
01400	EXPLODE:	HRRZI R,EXPL1
01500		MOVSI AR1,AR1
01600		PUSHJ P,PRINTA
01700		JRST SUBS4
01800	
01900	EXPL1:	PUSH P,B
02000		PUSH P,C
02100		ANDI A,177
02200		CAIL A,"0"
02300		CAILE A,"9"
02400		JRST EXPL2
02500		ADDI A,INUM0-"0"
02600		JRST EXPL4
02700	
02800	EXPL2:	PUSH P,AR1
02900		PUSH P,TT
03000		PUSH P,T
03100		LSH A,35
03200		MOVE C,SP
03300		PUSH C,A
03400		MOVEI AR1,1
03500		PUSHJ P,INTER0
03600		POP P,T
03700		POP P,TT
03800		POP P,AR1
03900	EXPL4:	PUSHJ P,NCONS
04000		HLR B,AR1
04100		HRRM A,(B)
04200		HRLM A,AR1
04300		POP P,C
04400		JRST POPBJ
04500	PAGE
04600	READLIST:	TDZA T,T
04700	MAKNAM:	MOVNI T,1
04800		MOVEM T,NOINFG
04900			PUSH P,OLDCH
05000		SETZM OLDCH
05100		JUMPE A,NOLIST
05200		HRRM A,MKNAM3
05300		MOVEI A,MKNAM2
05400		PUSHJ P,READ0
05500		HRRZ T,MKNAM3
05600		CAIE T,-1
05700		JUMPN T,[ERR1 [SIXBIT /MORE THAN ONE S-EXPRESSION-MKNAM!/]]
05800		POP P,OLDCH
05900		POPJ P,
06000	
06100	MKNAM2:	PUSH P,B
06200		PUSH P,T
06300		PUSH P,TT
06400		HRRZ	TT,MKNAM3#
06500		JUMPE TT,MKNAM6
06600		CAIN TT,-1
06700		ERR1 [SIXBIT /READ UNHAPPY-MAKNAM!/]
06800		HRRZ B,(TT)
06900		HRRM B,MKNAM3
07000		HLRZ A,(TT)
07100		CAIGE A,INUMIN
07200		JRST MKNAM5
07300		SUBI A,INUM0-"0"
07400	MKNAM4:	POP P,TT
07500		POP P,T
07600		JRST POPBJ
07700	
07800	MKNAM5:	HLRZ A,(TT)
07900		MOVEI B,PNAME(S)
08000		PUSHJ P,GET
08100		HLRZ A,(A)
08200		LDB A,[POINT 7,(A),6]
08300		JRST MKNAM4
08400	
08500	MKNAM6:	MOVEI A," "
08600		HLLOS MKNAM3
08700		JRST MKNAM4
08800	
08900	;	A COUPLE OF FUNCTIONS SO THAT THE PROGRAMMER MAY RETURN CELLS TO THE FREE LIST
09000	FREE:	MOVEM	F,(A)	;$$ RETURN A SINGLE CELL TO FREE LIST
09100		HRRZ	F,A
09200		JRST	FALSE
09300	FREELI:	JUMPE	A,CPOPJ	;$$ RETURN A LIST TO THE FREE LIST
09400		HRRZ	B,(A)
09500		MOVEM	F,(A)
09600		HRRZ	F,A
09700		MOVE	A,B
09800		JRST	FREELI
     

00100	
00200	
00300	APPLY.:	CAILE A,INUMIN	;$$ AN APPLY TO HANDLE ANY FUNCTION TYPE
00400		JRST UNDTAG
00500		HLRZ T,(A)
00600		CAIE T,-1
00700		JRST GAPP
00800		HRRZ T,(A)
00900	AAGN:	JUMPE T,GAPP
01000		HLRZ TT,(T)
01100		HRRZ T,(T)
01200		CAIN TT,FSUBR(S)
01300		JRST	[MOVE A,B
01400			 HLRZ T,(T)
01500			 JRST (T)]
01600		CAIN TT,FEXPR(S)
01700		JRST [	HLRZ T,(T)
01800			HRL T,A
01900			PUSH P,T
02000			MOVE A,B
02100			JRST APPL.2]
02200		CAIN TT,MACRO(S)
02300		JRST [	PUSHJ P,CONS
02400			JRST EVAL]
02500		CAIN TT,EXPR(S)
02600		JRST GAPP
02700		CAIN TT,SUBR(S)
02800		JRST GAPP
02900		CAIE TT,LSUBR(S)
03000		JRST AAGN
03100	GAPP:	HRREI T,-2
03200		PUSH P,A
03300		PUSH P,B
03400		JRST APPLY
03500	
03600			SUBTTL EVAL APPLY  -- THE INTERPRETER  --- PAGE 13
03700	EV3:	HLRZ A,(AR1)
03800		MOVEI B,VALUE(S)
03900		PUSHJ P,GET
04000		JUMPE A,UNDFUN	;function object has no definition
04100		HRRZ A,(A)
04200	REMOTE<
04300	XXX4:
04400	UBDPTR:	UNBOUND>
04500		HLRZ	B,(AR1)		;$$GET ORIGINAL FN NAME
04600		CAME	A,B		;$$IF VALUE IS THE SAME THE WE HAVE A LOOP
04700		CAMN A,UBDPTR
04800		JRST UNDFUN
04900		HRRZ B,(AR1)	;eval (cons (cdr a)(cdr ar1))
05000		PUSHJ P,CONS
05100		JRST XXEVAL
05200	PAGE
05300	OEVAL:	AOJN T,AEVAL
05400		POP P,A
05500	EVAL:	PUSH	P,SP	;$$SAVE SPDL
05600		PUSHJ	P,XXEVAL	;$$GO DO EVALUATION AS USUAL
05700		POP	P,SP	;$$RESTORE SPDL
05800		POPJ	P,	;$$AND RETURN TO CALLER
05900	
06000	XXEVAL:	HRRZM A,AR1
06100		CAILE A,INUMIN
06200		JRST CPOPJ
06300	
06400	;$$CODE TO PUT EVAL BLIP ON SPECIAL PDL
06500	
06600		PUSH P,B	;$$SAVE WHAT WAS IN B
06700		HRRZI	B,-1(P)	;$$GET RPDL POINTER AND OFFSET
06800		HRLI B,UNBOUND(S)	;$$ SET UP RPDL POINTER
06900		PUSH SP,B	;$$ SAVE RPDL POINTER ON SPDL
07000		PUSH	SP,A	;$$SAVE EVAL FORM ON SPDL
07100		POP	P,B	;$$AND GO OON
07200		HLRZ	T,(A)	;;;;;;;;;;;;; 
07300	
07400	
07500		SKIPN ERINT#	;$$CHECK IF DDT (CONTROL H) INTERRUPT OCCURRED
07600		JRST .+4	;$$SKIP OVER INTERRUPT FEATURE
07700		SETZM	ERINT#	;$$TURN OFF INTERRUPT FLAG
07800		PUSHJ P,EPRINT	;$$PRINT OUT WHAT WAS INTERRUPTED
07900		ERR1 [SIXBIT /WAS JUST INTERRUPTED - NOW IN ERRORX!/]
08000	
08100		CAIN T,-1
08200		JRST EE1		;x is atomic
08300		CAILE T,INUMIN
08400		JRST UNDFUN
08500	
08600	
08700		HLRO TT,(T)
08800		AOJE TT,EE2		;car (x) is atomic
08900		JRST EXP3
09000	
09100	EE1:
09200	EV5:	HRRZ AR1,(AR1)
09300		JUMPE AR1,UNBVAR
09400		HLRZ TT,(AR1)
09500		CAIE TT,FLONUM(S)
09600		CAIN TT,FIXNUM(S)
09700		POPJ P,
09800	EVBIG:	HRRZ AR1,(AR1)		;bignums know about me
09900		CAIE TT,VALUE(S)
10000			JRST EV5
10100		HLRZ AR1,(AR1)
10200		HRRZ AR1,(AR1)
10300		CAIN AR1,UNBOUND(S)
10400		JRST UNBVAR
10500		MOVEM AR1,A
10600		POPJ P,
10700	PAGE
10800	;	HANDLER OF ALISTS AND SPDL CONTEXT POINTERS
10900	
11000	ALIST:	SKIPE  A,-1(P)
11100		PUSHJ P,NUMBERP
11200		MOVEM SP,SPSV
11300		JUMPN A,AEVAL7	;number
11400		MOVE C,SC2	;bottom of spec pdl
11500		MOVEM C,AEVAL5#
11600		SETOM AEVAL2
11700	AEVAL8:	MOVE C,SP
11800	AEVAL6:	CAMN C,AEVAL5	;bottom spec pdl
11900		JRST AEVAL1	;done
12000		POP C,T		;pointer for next block
12100		JUMPGE	T,AEVAL6	;$$SKIP ANY EVAL BLIP CRAP
12200	AEVAL4:	CAMN C,T
12300		JRST AEVAL6	;thru with block
12400		POP C,AR1
12500		TLNE	AR1,-1		;$$ TEST FOR EVAL BLIP
12600		JRST	.+3
12700		SUB	C,[XWD 1,1]	;$$ FOUND ONE, SKIP RPDL WORD
12800		JRST	AEVAL4
12900		MOVSS AR1
13000		PUSH SP,(AR1)	;save value cell
13100		HLRM AR1,(AR1)	;store previous value in value cell
13200		HRLM AR1,(SP)	;save pointer to spec pdl loc
13300		JRST AEVAL4
13400	
13500		AEVAL:	PUSHJ P,ALIST
13600		POP P,A
13700		MOVEI A,UNBIND
13800		EXCH A,(P)
13900		JRST EVAL
14000	PAGE
14100	AEVAL1:	SKIPGE AEVAL2
14200		SKIPN B,-1(P)
14300		JRST ABIND3	;done with binding
14400	
14500				;alist binding
14600		MOVE A,B
14700		PUSHJ P,REVERSE
14800		SKIPA
14900	ABIND2:	MOVE A,B
15000		HRRZ B,(A)
15100		HLRZ A,(A)
15200		HRRZ AR1,(A)
15300		HLRZ A,(A)
15400		PUSHJ P,BIND
15500		JUMPN B,ABIND2
15600	ABIND3:	PUSH SP,SPSV
15700		POPJ P,
15800	
15900	;spec pdl binding
16000	AEVAL7:	MOVE A,-1(P)
16100		PUSHJ P,NUMVAL
16200		JUMPL	A,.+5	;MAKE SURE IT IS A VALID STACK POINTER
16300		MOVS	T,SC2	;IT'S NOT, MAKE IT VALID
16400		ADD	T,A
16500		ADD	A,SC2
16600		HRL	A,T
16700		CLEARM AEVAL2#
16800		MOVEM A,AEVAL5	;point to unbind to
16900		JRST AEVAL8
17000	
17100	;AEVAL2:	0	;0 for number, -1 for a-list
17200	PAGE
17300	
17400	EE2:	HRRZ T,(T)
17500		JUMPE T,EV3
17600		HLRZ TT,(T)
17700		HRRZ T,(T)
17800		CAIN TT,SUBR(S)
17900		JRST ESB
18000		CAIN TT,LSUBR(S)
18100		JRST EELS
18200		CAIN TT,EXPR(S)
18300		JRST AEXP
18400		CAIN TT,FSUBR(S)
18500		JRST EFS
18600		CAIN TT,MACRO(S)
18700		JRST EFM
18800		CAIE TT,FEXPR(S)
18900		JRST EE2
19000	
19100		HLRZ T,(T)
19200		HLL T,(AR1)
19300		PUSH P,T
19400		HRRZ A,(A)
19500	APPL.2:	TLO A,400000
19600		PUSH P,A
19700		MOVNI T,1
19800		JRST IAPPLY
19900	
20000	AEXP:	HLRZ T,(T)
20100		HLL T,(AR1)
20200	EXP3:	PUSH P,T
20300		HRRZ A,(AR1)
20400	CILIST:	JSP TT,ILIST
20500	EXP2:	JRST IAPPLY
20600	
20700	EFS:	HLRZ T,(T)
20800		HRRZ A,(AR1)
20900		JRST (T)
21000	PAGE
21100	ESB:	HRRZ A,(AR1)
21200	UUOS2:	HLRZ T,(T)
21300		HLL T,(AR1)
21400		PUSH P,T
21500		JSP TT,ILIST
21600	ESB1:	JRST .+NACS+1(T)
21700		POP P,A+4
21800		POP P,A+3
21900		POP P,A+2
22000		POP P,A+1
22100	POPAJ:	POP P,A
22200		POPJ P,
22300	
22400	EFM:	HLRZ T,(T)
22500		CALLF 1,(T)
22600		JRST EVAL
22700	PAGE
22800	
22900	APPLY:	MOVEI TT,AP2
23000		CAME T,[-3]
23100		JRST PDLARG
23200		MOVEM T,APFNG1#
23300		PUSHJ P,ALIST
23400		MOVE T,APFNG1
23500		JSP TT,PDLARG
23600		PUSH P,[UNBIND]
23700	AP2:	PUSH P,A
23800		MOVEI T,0
23900	AP3:	JUMPE B,IAPPLY	;all args pushed; b has arg list
24000		HLRZ C,(B)
24100		PUSH P,C	;push arg
24200		HRRZ B,(B)
24300		SOJA T,AP3
24400	
24500	IAP4:	JUMPGE D,TOOFEW	;special case for fexprs
24600		AOJN R,TOOFEW
24700		PUSH P,B
24800		MOVE A,SP
24900		PUSHJ P,FIX1A
25000		EXCH A,(P)
25100		MOVE B,A
25200		MOVNI R,2
25300		SOJA T,IAP5
25400	
25500	FUNCT:	PUSH P,A
25600		MOVE A,SP
25700		PUSHJ P,FIX1A
25800		POP P,B
25900		HLRZ B,(B)
26000		PUSHJ P,XCONS
26100		MOVEI B,FUNARG(S)
26200		JRST XCONS
26300	PAGE
26400	APFNG:	SOS T
26500		MOVEM T,APFNG1
26600		JSP TT,PDLARG	;get args and funarg list
26700		HRRZ A,(A)
26800		HRRZ D,(A)	;a-list pointer
26900		HLRZ A,(A)	;function
27000		HRLZ R,APFNG1	;no. of args
27100		PUSH P,[UNBIND]
27200		JSP TT,ARGP1	;replace args and fn name
27300		PUSH P,D	;a-list pointer
27400		PUSHJ P,ALIST	;set up spec pdl
27500		POP P,D
27600		AOS T,APFNG1
27700	
27800	;falls through
27900	PAGE
28000	;falls in
28100	
28200	IAPPLY:	MOVE C,T	;state of world at entrance
28300		ADDI C,(P)	;t has - number of args on pdl
28400	ILP1A:	HRRZ B,(C)	;next pdl slot has function- poss fun name in lh
28500		CAILE B,INUMIN
28600		JRST UNDTAC
28700		HLRZ A,(B)
28800		CAIN A,-1
28900		JRST IAP1	;fn is atomic
29000		CAIN A,LAMBDA(S)
29100		JRST IAPLMB
29200		CAIN A,FUNARG(S)
29300		JRST APFNG
29400		CAIN A,LABEL(S)
29500		JRST APLBL
29600		PUSH P,T
29700		MOVE A,B
29800		PUSHJ P,EVAL
29900		POP P,T
30000		MOVE C,T
30100		ADDI C,(P)
30200	ILP1B:	MOVEM A,(C)
30300		JRST ILP1A
30400	
30500	IAPXPR:	HLRZ A,(B)
30600		JRST ILP1B
30700	IAP1:	HRRZ B,(B)
30800		JUMPE B,IAP2
30900		HLRZ TT,(B)
31000		HRRZ B,(B)
31100		CAIN TT,EXPR(S)
31200		JRST IAPXPR
31300		CAIN TT,LSUBR(S)
31400		JRST IAP6
31500		CAIE TT,SUBR(S)
31600		JRST IAP1
31700		HLRZ B,(B)
31800		MOVEM B,(C)
31900		JRST ESB1
32000	PAGE
32100	IAPLMB:	HRRZ B,(B)
32200		HLRZ TT,(B)
32300		MOVEM SP,SPSV
32400		HRRZ B,(B)
32500		HLRZ D,(TT)
32600		CAIN D,-1
32700		JUMPN TT, IAP3
32800		MOVE R,T
32900		IPLMB1:	JUMPE T,IPLMB2	;no more args
33000		JUMPE TT,TOMANY	;too many args supplied
33100	IAP5:	HLRZ A,(TT)
33200		MOVEI AR1,1(T)
33300		ADD AR1,P
33400		HLLZ D,(AR1)
33500		HRLM A,(AR1)
33600		HRRZ TT,(TT)
33700		AOJA T,IPLMB1
33800	PAGE
33900	
34000	
34100	IPLMB2:	JUMPN TT,IAP4	;too few args supplied
34200		JUMPE R,IAP69
34300	IPLMB4:	POP P,AR1
34400		HLRZ A,AR1
34500		AOJG R,IPLMB3
34600		PUSHJ P,BIND
34700		JRST IPLMB4
34800	IPLMB3:	SKIPE BACTRF
34900		JRST APBK1
35000	APBK2:	MOVEI A,NIL	;$$SETUP FOR IMPLIED PROG
35100		PUSH SP,SPSV
35200		MOVE T,B	;$$SETUP FOR IMPLIED PROG
35300		PUSHJ P,COND2+1	;$$INSTEAD OF EVAL
35400		JRST UNBIND
35500	
35600	IAP69:	POP P,(P)
35700		MOVEI A,NIL	;$$SETUP FOR IMPLIED PROG
35800		MOVE T,B	;$$
35900		JRST COND2+1	;$$INSTEAD OF EVAL
36000	
36100	APBK1:	HRRI AR1,CPOPJ 
36200		TLNE AR1,-1
36300		PUSH P,AR1
36400		JRST APBK2
36500	IAP6:	MOVEI TT,CPOPJ
36600		MOVEM TT,(C)
36700		HLRZ B,(B)
36800		JRST (B)
36900	
37000	APLBL:	MOVEM SP,SPSV
37100		HRRZ B,(B)
37200		HLRZ A,(B)
37300		HRRZ B,(B)
37400		HLRZ AR1,(B)
37500		MOVEM AR1,(C)
37600		PUSHJ P,BIND
37700		MOVEI A,APLBL1
37800		EXCH A,-1(C)
37900		EXCH A,LBLAD#
38000		HRLI A,LBLAD
38100		PUSH SP,A
38200		PUSH SP,SPSV
38300		JRST IAPPLY
38400	APLBL1:	PUSH P,LBLAD
38500			JRST SPECSTR
38600	
38700	IAP2:	HRRZ A,(C)
38800		MOVEI B,VALUE(S)
38900		PUSHJ P,GET
39000		JUMPE A,UNDTAC
39100		HRRZ A,(A)
39200		HRRZ B,(C)	;$$GET ORIGINAL FN NAME
39300		CAME A,B	;$$IF THE VALUE IS THE SAME THEN WE HAVE A LOOP
39400		CAIN A,UNBOUND(S)
39500		JRST UNDTAC
39600		JRST ILP1B
39700	
39800	IAP3:	MOVNI AR1,-INUM0(T)	;lexpr call
39900		MOVE A,TT
40000		PUSHJ P,BIND
40100		PUSH P,%ARG
40200		SUBI C,INUM0
40300		HRRM C,%ARG
40400		PUSH SP,SPSV
40500		MOVEI A,NIL	;$$ MORE FOR IMPLIED PROG
40600		MOVE T,B	;$$
40700		PUSHJ P,COND2+1	;$$ INSTEAD OF EVAL
40800		HRRZ T,%ARG
40900		POP P,%ARG
41000		SUBI T,1-INUM0(P)
41100		HRLI T,-1(T)
41200		ADD P,T
41300		JRST UNBIND
41400	
41500	ARG:	HRRZ A,@%ARG
41600		POPJ P,
41700	
41800	REMOTE<%ARG:	XWD A,0>
41900	SETARG:	HRRZM B,@%ARG
42000		JRST PROG2
42100	PAGE
42200	BIND:	JUMPE A,BNDERR	;$$CAN'T REBIND NIL
42300		CAIN A,TRUTH(S)	;$$SHOULDN'T REBIND T
42400		JRST BNDERR	;$$
42500		PUSH P,B
42600		HRRZM A,BIND3#
42700	BIND2:
42800		MOVEI B,VALUE(S)	;bind atom in a to value in ar1,save
42900		PUSHJ P,GET	;old binding on s pdl
43000		JUMPE A,BIND1	;add value cell
43100		PUSH SP,(A)
43200		HRLM A,(SP)
43300	
43400		HRRM AR1,(A)	;$$THIS WAS HHRZM AR1,(A) WHICH CLOBBERED ATOM POINTER IN MY SYSTEM
43500	POPBJ:	POP P,B
43600		POPJ P,
43700	
43800	BIND1:
43900		MOVEI B,UNBOUND(S)
44000	
44100		MOVE A,BIND3	;$$SET UP ATOM POINTER FROM SPECIAL CELL
44200				;$$THIS WAS MOVEI A,0
44300		PUSHJ P,CONS
44400		HRRZ B,@BIND3
44500		PUSHJ P,CONS
44600		MOVEI B,VALUE(S)
44700		PUSHJ P,XCONS
44800		HRRM A,@BIND3
44900			MOVE A,BIND3
45000		JRST BIND2
45100	
45200	UBD:	CAMG SP,B
45300		POPJ P,
45400	
45500	
45600		HLRZ	TT,(SP)	;$$SKIP OVER EVAL BLIPS ETC.
45700		JUMPE	TT,.+2	;$$IF EQUAL TO 0 IT WAS AN EVAL BLIP
45800		JRST	PJUBND
45900		SUB	SP,[XWD 2,2]	;$$DECREMENT SPDL
46000		JRST	UBD		;$$GO BACK AND CHECK
46100	
46200	PJUBND:	PUSHJ P,UNBIND
46300		JRST UBD
46400	
46500	UNBIND:
46600	SPECSTR:	MOVE TT,(SP)
46700		CAMN	SP,SC2	;$$CHECK TO AVOID OVERSHOOT
46800		POPJ	P,	;$$
46900	
47000		SUB SP,[XWD 1,1]
47100		JUMPGE TT,UNBIND	;syncronize stack
47200	UNBND1:	CAMN SP,TT
47300		POPJ P,
47400		POP SP,T
47500	
47600	
47700		CAIN T,(T)	;$$CHECK TO SKIP OVER NEW ITEMS PUT ON SPDL
47800				;$$ALL SUCH ITEMS HAVE 0 LEFT HAND SIDES
47900		JRST PROGUB	;$$THIS IS AN EVAL BLIP - CHECK IF A PROG
48000	
48100		MOVSS T
48200	
48300		HLRM T,(T)	;$$CHANGED FROM HLRZM T,(T) TO PROTECT NEW ATOM POINTER
48400	
48500		JRST UNBND1
48600	
48700	
48800	PROGUB:	HLRZ T,(T)	;$$CHECK FOR A PROG
48900		CAIE T,PROGAT+1(S)	;$$CHECK IF IT IS A PROG
49000		JRST PROGU1	;$$NOT A PROG, SKIP IT AND GO ON
49100		MOVE T,(SP)	;$$GET THE RPDL POINTER FOR PROG INTO T
49200		ADDI T,2	;$$INCREMENT TO GET TO WHERE PA3,PA4 SAVED
49300		POP T,PA4	;$$RESTORE PA4
49400		POP T,PA3	;$$AND PA3 FROM WHERE THEY WERE SAVED
49500	PROGU1:	POP SP,T	;$$ POP RPDL POINTER
49600		JRST UNBND1	;$$AND GO ON WITH THE UNBINDING
49700	
49800	
49900	
50000	SPECBIND:	MOVE TT,SP
50100	SPEC1:	LDB R,[POINT 13,(T),ACFLD]
50200		CAILE R,17
50300		JRST SPECX
50400		SKIPE R
50500		MOVE R,(R)
50600		HLL R,@(T)	;$$AGAIN SAVE THE POOR LITTLE ATOM POINTER
50700		EXCH R,@(T)
50800		HRLI R,@(T)
50900		PUSH SP,R
51000		AOJA T,SPEC1
51100	SPECX:	PUSH SP,TT
51200		JRST (T)
51300	
51400	;random special case compiler run time routines
51500	
51600	%AMAKE:	PUSH P,A	;make alist for fsubr that requires it
51700		MOVE A,SP
51800		PUSHJ P,FIX1A
51900		MOVE B,A
52000		JRST POPAJ
52100	
52200	%UDT:	PUSHJ P,PRINT	;error print for undefined computed go tag
52300		STRTIP [SIXBIT /UNDEFINED COMPUTED GO TAG IN !/]
52400		HRRZ R,(P)
52500		PUSHJ P,ERSUB3
52600		JRST ERREND
52700	
52800	%LCALL:	MOVN A,T	;set up routine for compile lsubr
52900		ADDI A,INUM0
53000		ADDI T,(P)
53100		PUSH P,T
53200		PUSHJ P,(3)
53300		POP P,T
53400		SUBI T,(P)
53500		HRLI T,-1(T)
53600		ADD P,T
53700		POPJ P,
     

00100			SUBTTL ARRAY SUBROUTINES  --- PAGE 14
00200	
00300	ARRERR=-1
00400	
00500	ARRAY:	PUSHJ P,ARRAYS
00600		HRRI AR2A,1(R)
00700		MOVE A,AR2A
00800		PUSH R,[0]
00900		AOBJN A,.-1
01000	ARREND:	MOVE A,BPPNR#
01100		MOVEM AR2A,-1(A)
01200		MOVEI A,INUM0+1(R)
01300		MOVEM A,VBPORG(S)
01400		POPJ P,
01500	
01600	ARRAYS:	PUSH P,A
01700		MOVE A,VBPORG(S)
01800		SUBI A,INUM0
01900		MOVEM A,BPPNR
02000		MOVE A,VBPEND(S)
02100		MOVNI A,-INUM0-2(A)
02200		ADD A,BPPNR	;bporg-bpend+2
02300		HRLM A,BPPNR
02400		POP P,A
02500		HRRZ AR1,(A)	;(cdr l)
02600		HLRZ A,(A)	;(car l)name
02700		HRRZ B,BPPNR
02800		ADDI B,2
02900		MOVEI C,SUBR(S)
03000		PUSHJ P,PUTPROP
03100		HLRZ A,(AR1)	;(cadr l)mode
03200		PUSH P,AR1
03300		PUSHJ P,EVAL	;eval mode
03400		POP P,AR1
03500		MOVEM A,AMODE#
03600		MOVEI C,44
03700		JUMPE A,ARRY1
03800		MOVEI C,-INUM0(A)
03900		CAILE A,INUMIN
04000		JRST ARRY1
04100		MOVEI C,22
04200		HRRZ A,BPPNR
04300		MOVE B,GCMKL
04400		PUSHJ P,CONS
04500		MOVEM A,GCMKL
04600	ARRY1:	MOVEM C,BSIZE#
04700		MOVEI A,44
04800		IDIV A,C
04900		MOVEM A,NBYTES#
05000		HRRZ A,(AR1)	;(cddr l)bound pair list
05100		JSP TT,ILIST
05200		AOS R,BPPNR
05300		MOVEI AR1,1	;ar1 is array size
05400		MOVEI AR2A,0	;ar2a is cumulative residue
05500		AOJGE T,ARRYS	;single dimension
05600		MOVEI D,A-1
05700		SUB D,T	;d is next ac for array code generation
05800	ARRY2:	PUSHJ P,ARRB0
05900		TLC TT,(IMULI)
06000		DPB D,[POINT 4,TT,ACFLD]
06100		PUSH R,TT
06200		CAIN D,A
06300		JRST ARRY3
06400		MOVSI TT,(ADD)
06500		ADDI TT,1(D)
06600		DPB D,[POINT 4,TT,ACFLD]
06700		PUSH R,TT
06800		SOJA D,ARRY2
06900	
07000	ARRB0:	POP P,TT
07100		EXCH TT,(P)
07200		CAILE TT,INUMIN
07300		JRST ARRB1
07400		HLRZ A,(TT)
07500		HRRZ TT,(TT)
07600		SUBI TT,(A)
07700		ADDI TT,1
07800		JRST ARRB2
07900	
08000	ARRB1:	MOVEI A,INUM0
08100		SUB TT,A
08200	ARRB2:	IMUL A,AR1
08300		IMULB AR1,TT
08400		ADDM A,AR2A
08500		POPJ P,
08600	
08700	ARRY3:	PUSH R,[ADD A,B]
08800	ARRYS:	PUSHJ P,ARRB0
08900		HRRZ TT,BPPNR
09000		MOVEM AR2A,(TT)
09100		HRLI TT,(SUB A,)
09200		PUSH R,TT
09300		PUSH R,[JUMPL A,ARRERR]
09400		MOVE TT,AR1
09500		HRLI TT,(CAIL A,)
09600		PUSH R,TT
09700		PUSH R,[JRST ARRERR]
09800		IDIV AR1,NBYTES	;calc #words in array
09900		SKIPE AR2A	;correct for remainder non-zero
10000		ADDI AR1,1
10100		MOVE TT,NBYTES
10200		SOJE TT,ARRY6
10300		ADDI TT,1
10400		HRLI TT,(IDIVI A,)
10500		PUSH R,TT
10600		MOVN TT,BSIZE
10700		LSH TT,14
10800		HRLI TT,(IMULI B,)
10900		PUSH R,TT
11000		MOVEI TT,44+200
11100		SUB TT,BSIZE
11200		LSH TT,6
11300	ARRY6:	ADD TT,BSIZE
11400		LSH TT,6
11500		SKIPE AR2A,AMODE
11600		CAIL AR2A,INUMIN
11700		ADDI TT,40	;mode not = t
11800		TLC TT,(HRLZI C,)
11900		PUSH R,TT
12000		MOVEI TT,4(R)
12100		HRLI TT,(ADDI C,(A))
12200		PUSH R,TT
12300		PUSH R,[LDB A,C]
12400		HRLZI AR2A,(POPJ P,)
12500		SKIPN TT,AMODE
12600		MOVE AR2A,[JRST FLO1A]
12700		CAIL TT,INUMIN
12800		MOVE AR2A,[JRST FIX1A]
12900		PUSH R,AR2A
13000		MOVS AR2A,AR1
13100		MOVNS AR2A
13200		POPJ P,
13300	
13400	PAGE
13500	EXARRAY:	PUSH P,A
13600		HLRZ A,(A)
13700		PUSHJ P,GETSYM
13800		JUMPE A,POPAJ
13900		PUSHJ P,NUMVAL
14000		EXCH A,(P)
14100		PUSHJ P,ARRAYS
14200		POP P,A
14300		HRRM A,-2(R)
14400		HRR AR2A,A
14500		JRST ARREND
14600	
14700	STORE:	PUSH P,A
14800		PUSHJ P,CADR
14900			PUSHJ P,EVAL	;value to store
15000		EXCH A,(P)
15100		HLRZ A,(A)
15200		PUSHJ P,EVAL	;byte pointer returned in c
15300		POP P,A
15400	NSTR:	PUSH P,A
15500		TLNE C,40
15600		PUSHJ P,NUMVAL	;numerical array
15700		DPB A,C
15800		POP P,A
15900		POPJ P,
     

00100			SUBTTL EXAMINE, DEPOSIT , ETC --- PAGE 15
00200	
00300	BOOLE:	MOVE TT,T
00400		ADDI TT,2(P)
00500		MOVE A,-1(TT)
00600		SUBI A,INUM0
00700		DPB A,[POINT 4,BOOLI,OPFLD-2]
00800		PUSHJ P,BOOLG
00900		MOVE C,A
01000	BOOLL:	PUSHJ P,BOOLG
01100		XCT BOOLI
01200	REMOTE<
01300	BOOLI:	CLEARB C,A>
01400		JRST BOOLL
01500	
01600		BOOLG:	CAIL TT,(P)
01700		JRST BOOL1
01800		MOVE A,(TT)
01900		PUSHJ P,NUMVAL
02000		AOJA TT,CPOPJ
02100	
02200	BOOL1:	HRLI T,-1(T)
02300		ADD P,T
02400		POP P,B
02500		JRST FIX1A
02600	
02700	EXAMINE:PUSHJ P,NUMVAL
02800		MOVE A,(A)
02900		JRST FIX1A
03000	
03100	DEPOSIT:MOVE C,B
03200		PUSHJ P,NUMVAL
03300		EXCH A,C
03400		PUSHJ P,NUMVAL
03500		MOVEM A,(C)
03600		JRST MAKNUM
03700	
03800	LSH:	MOVEI C,-INUM0(B)
03900		PUSHJ P,NUMVAL
04000		LSH A,(C)
04100		JRST FIX1A
     

00100			SUBTTL GARBAGE COLLECTER   --- PAGE 16
00200	
00300	;garbage collector
00400	
00500	GC:	PUSHJ P,AGC
00600		JRST FALSE
00700	
00800	AGC:	SETOM	GCFLG	;SET GCFLAG INCASE OF USER CONTROL-C
00900		MOVEM R,RGC#
01000	GCPK1:	PUSH P,PA3
01100		PUSH P,PA4
01200		PUSH P,UBDPTR	;special atom UNBOUND; not on OBLIST
01300		PUSH P,MKNAM3
01400		PUSH P,GCMKL	;i/o channel input lists and arrays
01500		PUSH P,BIND3
01600		PUSH P,INITF
01700	GCPK2:	PUSH P,[XWD 0,GCP6]	;this is a return address
01800		JRST GCP4
01900	REMOTE<
02000	GCP4:	MOVEI S,X	;pdlac, .=bottom of reg pdl + 1
02100	GCP41:	BLT S,X	;save ACs 0 through 10 at bottom of regpdl	;pdlac+n
02200	GCP2:	CLEARB 0,X	;gc indicator, init. for bit table zero
02300		MOVE A,C3GC
02400	GCP5:	BLT A,X	;zero bit tables, .=top of bit tables
02500		JRST GCRET1>
02600	GCRET1:	SKIPN GCGAGV
02700		JRST GCP5A
02800		SKIPN F
02900		STRTIP [SIXBIT /←FREE STG EXHAUSTED←!/]
03000		SKIPN FF
03100		STRTIP [SIXBIT /←FULL WORD SPACE EXHAUSTED←!/]
03200	
03300	GCP5A:	MOVEI TT,1
03400		MOVEI A,0
03500		CALLI A,STIME	;time
03600		MOVNS A
03700		ADDM A,GCTIM#
03800		MOVE C,GCP3#	;.=bottom of reg pdl
03900	GCP6B:	MOVE S,P
04000		HLL C,P
04100		MOVEI B,0
04200	GC1:	CAMN C,S
04300		POPJ P,
04400		HRRZ A,(C)
04500	GCPI:	CAMGE A,GCP#	;.=bottom of bit tables
04600	REMOTE<
04700	GCPP1:
04800	XXX5:FS>
04900		CAMGE A,GCPP1
05000		JRST GCEND
05100		CAML A,GCP1#	;.=bottom of full word space (fws)
05200		JRST GCMFW
05300		MOVE F,(A)
05400		LSHC A,-5
05500		ROT B,5
05600		MOVE AR1,GCBT(B)
05700		TDOE AR1,@GCBTP2	;bit tab- (fs←-5), .=magic number for sync
05800		JRST GCEND
05900		MOVEM AR1,@GCBTP1	;bit tab- (fs←-5)
06000		PUSH P,F
06100		HLRZ A,F
06200		JRST GCPI
06300	REMOTE<
06400	GCBTP1:	XWD A,0
06500	GCBTP2:	XWD A,0
06600	GCMFWS:	XWD A,0>
06700	
06800	GCMFW:	MOVEI AR1,@GCMFWS	;.=- bottom of fws
06900		IDIVI AR1,44
07000		MOVNS AR2A
07100		LSH AR2A,36
07200		ADD AR2A,C2GC
07300		DPB TT,AR2A
07400	GCEND:	CAMN P,S
07500		AOJA C,GC1
07600		POP P,A
07700		HRRZS A
07800		JRST GCPI
07900	REMOTE<
08000		GCMKL:	XWD 0,[XWD [XWD -NIOCH,CHTAB+FSTCH],0]
08100	C2GC:	XWD 430100+AR1,X	;.=bottom of fws bit table
08200	C3GC:	0>	;(bottom bit table)bottom bit table+1
08300	GCBT:	XWD 400000,0
08400	ZZ==1B1
08500	XLIST
08600	REPEAT ↑D31,<ZZ
08700	ZZ==ZZ/2>
08800	LIST
08900	GCP6:	HRRZ R,SC2
09000	GCP6C:	CAIL R,(SP)	;mark sp
09100		JRST GCP6A
09200		PUSH P,(R)
09300		HRRZ C,P
09400		PUSHJ P,GCP6B
09500		SUB P,[XWD 1,1]
09600		AOJA R,GCP6C
09700	
09800	GCP6A:	HRRZ R,GCMKL	;mark arrays
09900	GCP6D:	JUMPE R,GCSWP
10000		HLRZ A,(R)
10100		MOVE D,(A)
10200	GCP6E:	PUSH P,(D)
10300		HRRZ C,P
10400		PUSH P,(D)
10500		MOVSS (P)
10600		PUSHJ P,GCP6B
10700		SUB P,[XWD 2,2]
10800		AOBJN D,GCP6E
10900		HRRZ R,(R)
11000		JRST GCP6D
11100	
11200	GFSWPP:
11300	PHASE 0
11400	GFSP1==.
11500		JUMPL S,.+3
11600		HRRZM F,(R)
11700		HRRZ F,R
11800		ROT S,1
11900		AOBJN R,.-4
12000		MOVE S,(D)
12100		HRLI R,-40
12200		AOBJN D,GFSP1
12300	
12400	LPROG==.
12500		JRST GFSPR
12600	
12700	DEPHASE
12800	;garbage collector sweep
12900	
13000	GCSWP:	MOVSI R,GFSWPP
13100		BLT R,LPROG
13200		MOVEI F,NIL	;will become movei f,-1
13300		MOVE D,C3GCS
13400		JRST	XXX3
13500	REMOTE<
13600	XXX3:	MOVEI R,FS	;$$ANOTHER FOOLIST REMNANT
13700	GCBTL1:	HRLI R,X	;-(32-<fs&37>
13800		MOVE S,(D)
13900	GCBTL2:	ROT S,X	;fs&37
14000		AOBJN D,GFSP1
14100		JRST GFSPR>
14200	GFSPR:	MOVE A,C1GCS
14300		MOVE B,C2GCS
14400		PUSHJ P,GCS0
14500		SKIPN GCGAGV
14600		JRST GCSPI1
14700		MOVE B,F
14800		PUSHJ P,GCPNT
14900		STRTIP [SIXBIT / FREE STG,!/]
15000		MOVE B,FF
15100		PUSHJ P,GCPNT
15200		STRTIP [SIXBIT / FULL WORDS AVAILABLE←!/]
15300	GCSPI1:	HRLZ S,GCSP1#	;bottom of reg pdl+1
15400		BLT S,NACS+3	;reload ac's
15500		SUB P,[XWD GCPK2-GCPK1,GCPK2-GCPK1]	;restore p
15600		AOSN	GCFLG		;CHECK FLAG FOR PENDING INTERRUPT
15700		JRST	GCEXIT		;NO- SO NORMAL EXIT
15800		POP	P,JOBOPC	;INTERRUPT WILL CONTINUE FROM THE GC RETURN
15900		PUSH	P,GCFLG		;GC WILL RETURN TO THE INTERRUPT POINT
16000		SETZM	GCFLG		;CLEAR GCFLG
16100	GCEXIT:	JUMPE F,[ERR2 [SIXBIT /NO FREE STG LEFT!/]]
16200		JUMPE FF,[ERR2 [SIXBIT /NO FW STG LEFT!/]]
16300		MOVE R,RGC
16400		MOVEI A,0
16500		CALLI A,STIME	;time
16600		ADDM A,GCTIM
16700		MOVE S,ATMOV	;$$RESTORE ATOM OFFSET RELOCATOR (FOOLIST)
16800				;$$HOPEFULLY S IS USED ONLY BY GC AND ATOM RELOCATION
16900	
17000		POPJ P,
17100	
17200	GCS0:	MOVEI FF,0
17300	GCS1:	ILDB C,B
17400		JUMPN C,GCS2
17500		HRRZM FF,(A)
17600		HRRZ FF,A
17700	GCS2:	AOBJN A,GCS1
17800		POPJ P,
17900	
18000	REMOTE<
18100	C1GCS:	0	;(- length of fws) bottom of fws
18200	C2GCS:	XWD 100,0	;.=bottom of fws bit table
18300	C3GCS:	0	;-n wds in bt,,bt
18400	>
18500	GCGAG:	EXCH A,GCGAGV#
18600		POPJ P,
18700	
18800	GCTIME:	MOVE A,GCTIM
18900		JRST FIX1A
19000	
19100	TIME:	MOVEI A,0
19200		CALLI A,STIME
19300		JRST FIX1A
19400	
19500	SPEAK:	MOVE A,CONSVAL#
19600		JRST FIX1A
19700	
19800	GCPNT:	MOVEI R,TTYO
19900		MOVEI A,0
20000		JUMPE B,PRINL1
20100		HRRZ B,(B)
20200		AOJA A,.-2
20300	
20400	GCING:	OUTSTR	[ASCIZ /
20500	GARBAGE COLLECTING
20600	/]
20700		POP	P,GCFLG	;CAN'T INTERRUPT GC, QUEUE UP THE REQUEST
20800		JRST	@JOBOPC
     

00100			SUBTTL GETSYM     --- PAGE 17
00200	
00300	R50MAK:	PUSHJ P,PNAMUK
00400		PUSH C,[0]
00500		HRLI C,700
00600		HRRI C,(SP)
00700		MOVEI B,0
00800	MK3:	ILDB A,C
00900		LDB A,R50FLD
01000		CAMGE B,[50*50*50*50*50]
01100		SKIPN A
01200		POPJ P,
01300		IMULI B,50
01400		ADD B,A
01500		JRST MK3
01600	
01700	GETSYM:	PUSHJ P,R50MAK
01800		TLO B,040000	;04 for globals
01900		MOVE C,JOBSYM
02000	MK7:	CAMN B,(C)
02100		JRST MK10	;found
02200		AOBJP C,.+2
02300		AOBJN C,MK7
02400		TLC B,140000	;10 for locals
02500		TLNE B,100000
02600		JRST MK7-1
02700		JRST FALSE
02800	
02900	MK10:	MOVE A,1(C)	;value
03000		JRST FIX1A
03100	
03200	PUTSYM:	PUSH P,B
03300		PUSHJ P,R50MAK
03400		MOVE A,B
03500		TLO A,040000	;make global
03600		SKIPL JOBSYM
03700		AOS JOBSYM	;increment initial symbol table pointer
03800		MOVN B,[XWD 2,2]
03900		ADDB B,JOBSYM
04000		MOVEM A,(B)	;name
04100		POP P,1(B)	;value
04200		JRST FALSE
04300	
04400	PATCH:	BLOCK 20
04500	
     

00100			SUBTTL ALVINE AND LOADER INTERFACES   --- PAGE 18
00200	
00300	;interface to alvine
00400	
00500	IFN ALVINE,<
00600	ED:	MOVE 10,EDA
00700		JRST (10)
00800		PUSH P,A
00900		HRRZ A,CORUSE
01000		HRRM A,LST
01100		AOS A
01200		HRRM A,EDA#
01300	
01400	
01500		HRRM	A,ED1	;$$SAVE REENTRY TO EDITOR
01600		AOS	ED1#	;$$
01700	
01800		MOVSI A,(SIXBIT /ED/)
01900		SETZ	D,	;THAT RELOCATION AGAIN - SEE BELOW
02000		PUSHJ P,SYSINI
02100		HRLM A,LST	
02200		MOVNS A
02300		PUSHJ P,MORCOR
02400		PUSHJ P,SYSINP+1
02500		POP P,A
02600		JRST ED
02700	GRINDEF:PUSH P,A
02800		PUSHJ P,ED
02900		POP P,A
03000		JRST 2(10)>
03100	
03200	EXCISE:
03300	IFN ALVINE<
03400		MOVEI A,ED+2
03500		HRRM A,EDA>
03600		MOVE A,JRELO
03700		SETZM LDFLG#	;initial loader symbol table flag
03800		CALLI A,CORE
03900		JRST .+1
04000		JSP R,IOBRST
04100		JRST TRUE
04200	
04300	PAGE
04400	;THIS IS THE NEW IMPROVED VERSION OF SPRINT
04500	 
04600	;  0(P) = A
04700	; -1(P) = B
04800	; -2(P) = C
04900	; -3(P) = M
05000	; -4(P) = N
05100	; -5(P) = X
05200	
05300	
05400	SPRINT:	SUBI B,INUM0
05500	SPRNT2:	PUSH P,A
05600		PUSH P,B
05700		SETZM M#
05800		SETZM CSW#
05900		MOVEM P,STP#
06000		MOVEI B,0
06100		PUSHJ P,DEPTH
06200		SKIPN B,M
06300		JRST .+6
06400		MOVE A,LINL
06500		SUB A,B
06600		SUB A,B
06700			IDIV A,B
06800		CAILE A,14
06900		MOVEI A,14
07000		MOVEM A,CUT#
07100		MOVE A,0(P)
07200		IDIV A,LINL
07300		CAIG B,0
07400		ADD B,LINL
07500		MOVEM B,0(P)
07600		MOVEI C,0
07700		JRST .+3
07800	 
07900	ISPRIN:	PUSH P,A
08000		PUSH P,B
08100		PUSH P,C
08200		PUSH P,[0]
08300		PUSH P,[0]
08400		PUSH P,[0]
08500		MOVE A,B
08600		SUB B,LINL
08700		JUMPLE B,.+3
08800		MOVE A,B
08900		MOVEM A,-4(P)
09000		PUSHJ P,POS
09100		MOVE A,-5(P)
09200		PUSHJ P,PATOM
09300		JUMPE A,.+4
09400	SPRN1:	MOVE A,-5(P)
09500		PUSHJ P,PRIN1
09600		JRST SPRN22
09700		MOVE B,LINL
09800		SUB B,-4(P)
09900		ADDI B,1
10000		MOVEM B,0(P)
10100		SUB B,-3(P)
10200		MOVE A,-5(P)
10300		PUSHJ P,FLATLE
10400		JUMPN A,SPRN1
10500		MOVEI A,50
10600		PUSHJ P,TYO
10700		AOS -4(P)
10800		SOS 0(P)
10900		HRRZ A,@-5(P)
11000		PUSHJ P,PATOM
11100		JUMPN A,SPRN13
11200		HLRZ A,@-5(P)
11300		CAIN A,LAMBDA(S)
11400		JRST LAM
11500		CAIN A,PROGAT+1(S)
11600		JRST PRG
11700		PUSHJ P,PATOM
11800		JUMPE A,SPRN3
11900		HLRZ A,@-5(P)
12000		PUSHJ P,PRIN1
12100		MOVE A,0(P)
12200		SUB A,CHCT
12300		MOVEM A,-1(P)
12400		CAIG A,24
12500		JRST SPRN4
12600		JRST SPRN12+4
12700	SPRN3:	MOVE B,0(P)
12800		CAILE B,20
12900		MOVEI B,20
13000		HLRZ A,@-5(P)
13100		PUSHJ P,FLATLE
13200		JUMPE A,SPRN12
13300		MOVEM A,-1(P)
13400	SPRN4:	HRRZ A,@-5(P)
13500		MOVEM A,-2(P)
13600		HRRZ A,0(A)
13700		PUSHJ P,PATOM
13800		JUMPN A,SPRN8
13900		MOVE B,-1(P)
14000		CAMG B,CUT
14100		JRST SPRN2
14200		SKIPE CSW
14300		JRST SPRN8
14400		MOVE A,0(P)
14500		SUB A,B
14600		SUBI A,1
14700		MOVEM A,-1(P)
14800		JRST SPRN5
14900	SPRN2:	HLRZ A,@-5(P)
15000		PUSHJ P,PATOM
15100		JUMPN A,.+3
15200		HLRZ A,@-5(P)
15300		PUSHJ P,PRIN1
15400		HRRZ A,@-5(P)
15500		MOVEM A,-5(P)
15600		MOVE A,-4(P)
15700		ADD A,-1(P)
15800		ADDI A,1
15900		MOVEM A,-4(P)
16000		JRST SPRN12
16100	SPRN5:	MOVE B,-1(P)
16200		HLRZ A,@-2(P)
16300		PUSHJ P,FLATLE
16400		JUMPE A,SPRN8
16500		HRRZ A,@-2(P)
16600		MOVEM A,-2(P)
16700		HRRZ A,0(A)
16800		PUSHJ P,PATOM
16900		JUMPE A,SPRN5
17000		HRRZ B,@-2(P)
17100		JUMPN B,.+3
17200		MOVE B,-1(P)
17300		SOJA B,SPRN7
17400		HRRZ A,@-2(P)
17500		PUSHJ P,FLATSI
17600		SUBI A,INUM0-4
17700		SUB A,-1(P)
17800		MOVN B,A
17900	SPRN7:	SUB B,-3(P)
18000		HLRZ A,@-2(P)
18100		PUSHJ P,FLATLE
18200		JUMPN A,SPRN18
18300	SPRN8:	HLRZ A,@-5(P)
18400		PUSHJ P,PATOM
18500		JUMPN A,.+3
18600	SPRN9:	HLRZ A,@-5(P)
18700		PUSHJ P,PRIN1
18800		HRRZ A,@-5(P)
18900		MOVEM A,-5(P)
19000		CAMN A,-2(P)
19100		JRST SPRN11
19200		MOVE A,-4(P)
19300		PUSHJ P,POS
19400		JRST SPRN9
19500	SPRN11:	HRRZ A,@-5(P)
19600		PUSHJ P,PATOM
19700		JUMPN A,SPRN13
19800	SPRN12:	MOVEI C,0
19900		MOVE B,-4(P)
20000		HLRZ A,@-5(P)
20100		PUSHJ P,ISPRIN
20200		HRRZ A,@-5(P)
20300		MOVEM A,-5(P)
20400		JRST SPRN11
20500	SPRN13:	HRRZ A,@-5(P)
20600		JUMPE A,.+4
20700		PUSHJ P,FLATSI
20800		SUBI A,INUM0-3
20900		ADDM A,-3(P)
21000		AOS -3(P)
21100		MOVE C,-3(P)
21200		MOVE B,-4(P)
21300		HLRZ A,@-5(P)
21400		PUSHJ P,ISPRIN
21500	SPRN16:	HRRZ A,@-5(P)
21600		JUMPE A,SPRN17
21700		MOVEI A,40
21800		PUSHJ P,TYO
21900		MOVEI A,56
22000		PUSHJ P,TYO
22100		MOVEI A,40
22200		PUSHJ P,TYO
22300		HRRZ A,@-5(P)
22400		PUSHJ P,PRIN1
22500	SPRN17:	MOVEI A,51
22600		PUSHJ P,TYO
22700		JRST SPRN22
22800	SPRN18:	HLRZ A,@-5(P)
22900		PUSHJ P,PATOM
23000		JUMPN A,.+3
23100		HLRZ A,@-5(P)
23200		PUSHJ P,PRIN1
23300		MOVEI A,40
23400		PUSHJ P,TYO
23500		HRRZ A,@-5(P)
23600		MOVEM A,-5(P)
23700		MOVE A,LINL
23800		SUB A,CHCT
23900		ADDI A,1
24000		MOVEM A,-4(P)
24100		HRRZ A,@-5(P)
24200		PUSHJ P,PATOM
24300		JUMPN A,SPRN21
24400	SPRN19:	HLRZ A,@-5(P)
24500		PUSHJ P,PRIN1
24600		HRRZ A,@-5(P)
24700		MOVEM A,-5(P)
24800		HRRZ A,0(A)
24900		PUSHJ P,PATOM
25000		JUMPN A,.+4
25100		MOVE A,-4(P)
25200		PUSHJ P,POS
25300		JRST SPRN19
25400		MOVE A,-4(P)
25500		PUSHJ P,POS
25600	SPRN21:	HLRZ A,@-5(P)
25700		PUSHJ P,PRIN1
25800		JRST SPRN16
25900	LAM:	PUSHJ P,PRIN1
26000		HRRZ A,@-5(P)
26100		MOVEM A,-5(P)
26200		MOVE B,-4(P)
26300		MOVEM B,-1(P)
26400		HLRZ A,0(A)
26500		PUSHJ P,PATOM
26600		MOVEI B,6
26700		CAIE A,NIL
26800		ADDI B,1
26900		ADDM B,-4(P)
27000		HRRZ A,@-5(P)
27100		PUSHJ P,PATOM
27200		JUMPN A,SPRN13
27300		MOVEI C,0
27400		MOVE B,-4(P)
27500		HLRZ A,@-5(P)
27600		PUSHJ P,ISPRIN
27700		MOVE B,-1(P)
27800		MOVEM B,-4(P)
27900		JRST SPRN12+4
28000	PRG:	PUSHJ P,PRIN1
28100		HRRZ A,@-5(P)
28200		MOVEM A,-5(P)
28300		MOVE A,-4(P)
28400		MOVEM A,-1(P)
28500		MOVEI A,5
28600		ADDM A,-4(P)
28700		HRRZ A,@-5(P)
28800		PUSHJ P,PATOM
28900		JUMPN A,SPRN13
29000		MOVEI C,0
29100			MOVE B,-4(P)
29200		HLRZ A,@-5(P)
29300		PUSHJ P,ISPRIN
29400		MOVE A,0(P)
29500		SUBI A,5
29600		MOVEM A,-2(P)
29700	PRG1:	HRRZ A,@-5(P)
29800		MOVEM A,-5(P)
29900		HRRZ A,0(A)
30000		PUSHJ P,PATOM
30100		JUMPN A,PRG3
30200		HLRZ A,@-5(P)
30300		PUSHJ P,PATOM
30400		JUMPE A,PRG2
30500		MOVE A,-1(P)
30600		PUSHJ P,POS
30700		HLRZ A,@-5(P)
30800		PUSHJ P,PRIN1
30900		JRST PRG1
31000		PRG2:	MOVE A,CHCT
31100		CAMG A,-2(P)
31200		PUSHJ P,TERPRI
31300		MOVEI C,0
31400		MOVE B,-4(P)
31500		HLRZ A,@-5(P)
31600		PUSHJ P,ISPRIN
31700		JRST PRG1
31800	PRG3:	HLRZ A,@-5(P)
31900		PUSHJ P,PATOM
32000		JUMPE A,SPRN13
32100		MOVE B,-1(P)
32200		MOVEM B,-4(P)
32300		JRST SPRN13
32400	SPRN22:	MOVEI A,NIL
32500		SUB P,[XWD 6,6]
32600		POPJ P,
32700	 
32800	POS:	PUSH P,A
32900		PUSH P,[0]
33000		MOVE A,LINL
33100		SUB A,CHCT
33200		ADDI A,1
33300		PUSH P,A
33400		CAMN A,-2(P)
33500		JRST POS4
33600		CAMG A,-2(P)
33700		JRST .+4
33800		PUSHJ P,TERPRI
33900		MOVEI A,1
34000		MOVEM A,0(P)
34100		SUBI A,1
34200		LSH A,-3
34300		ADDI A,1
34400		LSH A,3
34500		ADDI A,1
34600		MOVEM A,-1(P)
34700		CAMLE A,-2(P)
34800		JRST POS3
34900	POS2:	MOVEI A,11
35000		PUSHJ P,TYO
35100		MOVE A,-1(P)
35200		MOVEM A,0(P)
35300		ADDI A,10
35400		JRST POS2-3
35500	POS3:	AOS A,0(P)
35600		CAMLE A,-2(P)
35700		JRST POS4
35800		MOVEI A,40
35900		PUSHJ P,TYO
36000		JRST POS3
36100	POS4:	SUB P,[XWD 3,3]
36200		POPJ P,
36300	 
36400	FLATLE:	JUMPLE B,ABORT+1
36500		SETZM M
36600		MOVEM B,N#
36700		MOVEM P,STP
36800	SCAN:	PUSH P,A
36900		PUSHJ P,PATOM
37000		JUMPN A,EXIT1-6
37100	NA:	AOS A,M
37200		CAMLE A,N
37300		JRST ABORT
37400		HLRZ A,@0(P)
37500		PUSHJ P,SCAN
37600		HRRZ A,@0(P)
37700		MOVEM A,0(P)
37800		JUMPN A,.+3
37900		AOS A,M
38000		JRST EXIT1-2
38100		MOVE A,0(P)
38200		PUSHJ P,PATOM
38300		JUMPE A,NA
38400		MOVEI A,4
38500		ADDB A,M
38600		CAMLE A,N
38700		JRST ABORT
38800		MOVE A,0(P)
38900		PUSHJ P,FLATSI
39000		SUBI A,INUM0
39100		ADDB A,M
39200		CAMLE A,N
39300		JRST ABORT
39400	EXIT1:	SUB P,[XWD 1,1]
39500		POPJ P,
39600	ABORT:	MOVE P,STP
39700		MOVEI A,NIL
39800		POPJ P,
39900	 
40000	DEPTH:	PUSH P,A
40100		PUSH P,B
40200		PUSHJ P,PATOM
40300		JUMPN A,D2
40400		AOS A,0(P)
40500		CAMLE A,LINL
40600		JRST OUT+1
40700		CAMLE A,M
40800		MOVEM A,M
40900		MOVE A,-1(P)
41000		PUSH P,A
41100		PUSH P,[0]
41200	D1:	HLRZ A,@-3(P)
41300		MOVE B,-2(P)
41400		PUSHJ P,DEPTH
41500		HRRZ A,@-3(P)
41600		MOVEM A,-3(P)
41700		MOVE B,-1(P)
41800		SETCMB C,0(P)
41900		JUMPN C,.+3
42000		HRRZ B,0(B)
42100		MOVEM B,-1(P)
42200		CAMN A,B
42300		JRST OUT
42400		PUSHJ P,PATOM
42500		JUMPE A,D1
42600		SUB P,[XWD 2,2]
42700	D2:	SUB P,[XWD 2,2]
42800		POPJ P,
42900		OUT:	SETOM CSW
43000		MOVE P,STP
43100		JRST @1(P)
43200	;
43300	;
43400	;(TAB X) TABS TO POSITION X DOING A (TERPRI) IF NECESSARY
43500	;
43600	.TAB:	PUSHJ	P,NUMVAL
43700		PUSHJ	P,POS		;LET POS IN SPRINT DO THE WORK
43800		JRST	FALSE
43900	PAGE
44000	;	lisp loader interface
44100	;	REG. D IS USED SINCE VARIABLES ARE MOVE WHEN LISP IS REENTRANT
44200	LOAD:	AOS B,CORUSE
44300		MOVEM B,OLDCU#
44400		MOVEM A,LDPAR#
44500		JUMPE A,LOAD2
44600		MOVE B,VBPORG(S)
44700		SUBI B,INUM0
44800	LOAD2:	MOVEM B,RVAL#	;final destination of loaded code
44900		MOVSI A,(SIXBIT /LOD/)
45000		SETZ	D,
45100		PUSHJ P,SYSINI
45200		SUBI A,150	;extra room for locations 0 to 137 and slop
45300		PUSH P,A
45400		MOVNS A		;length(loader)
45500		HRRZM A,LODSIZ#
45600		PUSHJ P,MORCOR	;expand core for loader
45700		MOVEM A,LOWLSP#	;location of blt'ed low lisp
45800		MOVN B,(P)	;length(loader)
45900		ADD B,A
46000		MOVEM B,HVAL#	;temporary destination of loaded code
46100		HRLI A,0
46200		MOVE D,A	;THIS IS THE RELOCATION, THE LOADER WILL SAVE IT
46300		BLT A,(B)	;blt up low lisp
46400		HLL A,NAME+3(D)	;-length(loader)
46500		HRRI A,137-1
46600		PUSHJ P,SYSINP
46700		SKIPE LDFLG(D)
46800		JRST LOAD3
46900		SETOM LDFLG(D)
47000		MOVSI A,(SIXBIT /SYM/)
47100		PUSHJ P,SYSINI
47200		MOVNS A		;length symbols
47300		PUSHJ P,MORCOR	;expand core for symbols
47400		SKIPGE B,JOBSYM
47500		SOS B		;if no symbol table, use original jobsym
47600		HLRZ A,NAME+3(D)	;-length(symbols)
47700		ADDB A,B
47800		HLL A,NAME+3(D)	;symbol table iowd
47900		PUSHJ P,SYSINP
48000		HRRM B,JOBSYM
48100		HLLZ A,NAME+3(D)
48200		ADDM A,JOBSYM
48300		SKIPA
48400	LOAD3:	SOS JOBSYM	;want jobsym to point one below 1st symbol
48500		MOVE 3,HVAL(D)	;h
48600		MOVE 5,RVAL(D)	;r
48700		MOVE 2,3
48800		SUB 2,5		;x=h-r
48900		HRLI 5,12	;(w)
49000		HRLI 2,11	;(v)
49100		SETZB 1,4
49200		JSP 0,140	;call the loader
49300		MOVEM 5,RLAST#(D)	;last location loaded(in final area)
49400		MOVE T,OLDCU(D)
49500		MOVE A,JOBSYM
49600		MOVEM A,JOBSYM(T)
49700		MOVE A,JOBREL
49800		MOVEM A,JOBREL(T)	;update jobrel
49900		HRLZ 0,LOWLSP(D)
50000		SOS LODSIZ(D)
50100		AOBJN 0,.+1
50200		BLT 0,@LODSIZ(D)	;blt down low lisp
50300		MOVE 0,@LOWLSP	;EVERY THING IS FIXED, DON'T NEED REG. D ANYMORE
50400		MOVE B,RLAST
50500		MOVE A,RVAL
50600		HRL A,HVAL
50700		SKIPE LDPAR
50800		JRST BINLD
50900		MOVE C,RLAST	;new coruse
51000	LDRET2:	BLT A,(B)	;blt down loaded code
51100		HRRZM C,CORUSE	;top of code loaded
51200		MOVEI B,1
51300		ANDCAM B,JOBSYM
51400		SUB C,JOBSYM	;length of free core
51500		ORCMI C,776000
51600		AOJGE C,START	;no contraction
51700		ADD C,JOBREL	;new top of core
51800		MOVE B,C
51900		PUSHJ P,MOVDWN
52000		HRLM C,JOBSA
52100		CALLI C,CORE	;contract core
52200		JRST .+1
52300		JRST START
52400	
52500	BINLD:	MOVEI C,INUM0(B)
52600		CAML C,VBPEND(S)
52700		JRST [	SETOM BPSFLG	;bps exceeded
52800			JRST START]
52900		MOVEM C,VBPORG(S)	;updat bporg
53000		SOS C,OLDCU	;old top of core
53100		JRST LDRET2
53200	
53300	SYSINI:	MOVEM A,NAME+1(D)
53400		IFN SYSPRG,<	MOVE A,[XWD SYSPRG,SYSPN]
53500				MOVEM A,NAME+3(D)>
53600		IFE SYSPRG,<	SETZM NAME+3(D)>
53700		INIT	17
53800		SYSDEV
53900		0
54000		JRST AIN.4+1
54100		LOOKUP NAME(D)
54200		JRST AIN.7+1
54300		MOVE	A,[IOWD 1,NAME+3]	;KLUDGE BECAUSE OF REG. D
54400		ADD	A,D
54500		MOVEM	A,INLOW(D)
54600		INPUT	INLOW(D)	;INPUT SIZE OF FILE
54700	REMOTE<
54800	INLOW:	IOWD 1,NAME+3
54900		0>
55000		HLRO A,NAME+3(D)
55100		POPJ P,
55200	
55300	REMOTE<
55400	NAME:	SYSNAM
55500		0
55600		0
55700		0>
55800	
55900	SYSINP:	MOVEM A,LST(D)
56000		INPUT LST(D)
56100		STATZ 740000
56200		ERR1 AIN.8
56300		RELEASE
56400		POPJ P,
56500	
56600	REMOTE<
56700	LST:	0
56800		0>
56900	PAGE
57000	MOVDWN:	HLRZ A,JOBSYM
57100		JUMPE A,MOVS1
57200		ADDI A,1(B)
57300		HRL A,JOBSYM
57400		HRRM A,JOBSYM
57500		BLT A,(B)	;downward blt
57600		POPJ P,
57700	
57800	MOVSYM:	MOVE B,JOBREL
57900		HRLM B,JOBSA
58000		HLRE A,JOBSYM
58100		JUMPE A,MOVS1
58200		ADDI B,1(A)	;new bottom of symbol table
58300		MOVNI A,1(A)
58400		ADD A,JOBSYM	;last loc of old symbol table
58500		HRRM B,JOBSYM
58600		PUSH P,C
58700		MOVE B,JOBREL	;last loc of new symbol table
58800		MOVE C,(A)	;simulated upward blt
58900		MOVEM C,(B)
59000		SUBI B,1
59100		ADDI A,-1	;lf+1,rt-1
59200		JUMPL A,.-4
59300		POP P,C
59400		POPJ P,
59500	
59600	MOVS1:	HRRZM B,JOBSYM
59700		POPJ P,
59800	
59900	;enter with size needed in a
60000	;exit with pointer in a to core
60100	
60200	MORCOR:	PUSH P,B
60300		HRRZ B,JOBSYM
60400		SUB B,CORUSE(D)
60500		SUBM A,B
60600		JUMPL B,EXPND2
60700		ADD B,JOBREL	;new core size
60800		CALLI B,CORE	;expand core
60900		ERR1 [SIXBIT /CANT EXPAND CORE !/]
61000		PUSH P,A
61100		PUSHJ P,MOVSYM
61200		POP P,A
61300	EXPND2:	MOVE B,CORUSE(D)
61400		ADDM A,CORUSE(D)
61500		MOVE A,B
61600		POP P,B
61700		POPJ P,
61800	PAGE
61900		SUBTTL HIGH SEGMENT FUNCTIONS
62000	
62100	REMOTE<VHGHORG:BHORG>
62200	HGHCOR:	JUMPE	A,NOWRT	;EXPAND CORE AND SET WRITE STATUS
62300		PUSHJ	P,NUMVAL
62400		JUMPLE	A,FALSE
62500		CLEARB	C,WRTSTS
62600		CALLI	C,SETUWP
62700	UWPERR:	ERR1	[SIXBIT /CAN'T CHANGE HIGH SEG. WRITE PROTECT!/]
62800		MOVE	B,VHGHORG
62900		ADD	B,A
63000		HRRZ	C,JOBHRL
63100		CAMG	B,C
63200		JRST	TRUE
63300	IFE STANSW,<	HRLZ	A,B
63400		CALLI	A,CORE >
63410	IFN STANSW,<	HRRZ A,B
63420		CALLI A,400015>
63500		ERR1	[SIXBIT /CAN'T EXPAND HIGH SEGMENT!/]
63600		JRST	TRUE
63700	NOWRT:	MOVEI	A,1
63800		MOVEM	A,WRTSTS
63900		CALLI	A,SETUWP
64000		JRST	UWPERR
64100		JRST	TRUE
64200	
64300	HGHORG:	SKIPE	A	;SET HIGH ORG. TO A AND RETURN OLD ORG.
64400		PUSHJ	P,NUMVAL
64500		PUSH	P,A
64600		MOVE	A,VHGHORG
64700		MOVEI	B,FIXNUM(S)
64800		PUSHJ	P,MAKNUM
64900		POP	P,B
65000		SKIPE	B
65100		MOVEM	B,VHGHORG
65200		POPJ	P,
65300	
65400	HGHEND:	HRRZ	A,JOBHRL	;GET VALUE OF END OF HIGH SEG.
65500		MOVEI	B,FIXNUM(S)
65600		JRST	MAKNUM
65700	
65800	;SETS THE GETSEG INFO. SO USER CAN HAVE OWN HIGH SEG.
65900	SETSYS:	MOVE	T,A	;MOVE ARGUMENT FOR UIOSUB
66000		PUSHJ	P,IOSUB	;BREAKS DOWN THE SPECIFICATION
66020		CAME	A,[SYSNAM]	;				*** MJC
66030	; We're not allowing him to name his segment the same as ours,	*** MJC
66040	;   since that causes problems for ATTSEG, so test for it.	*** MJC
66050		JRST	GUDSEG	;					*** MJC
66053		MOVE	B,[SYSDEV]	; But if he's a system hacker	*** MJC
66056		CAME	B,DEV		;   then we let him get away	*** MJC
66059		JRST	BADSEG		;   with it.			*** MJC
66100	GUDSEG:	MOVEM	A,HGHDAT+1	;SAVE THE FILE NAME
66200		MOVE	A,DEV		;GET THE DEVICE AND SAVE IT
66300		MOVEM	A,HGHDAT
66350		MOVEM	A,INTDAT+1	; Save it for OPEN, too.	*** MJC
66400		MOVE	A,PPN		;GET THE PPN AND SAVE IT
66450		MOVEM	A,SGPPPN	;				*** MJC
66500		MOVEM	A,HGHDAT+4
66504		SKIPN	A,EXT		; Get extension and save it.	*** MJC
66511		MOVE	A,[SIXBIT/SEG/]	; No ext -- use SEG instead.	*** MJC
66518		MOVEM	A,HGHDAT+2	; Move ext into OPEN stuff.	*** MJC
66525		OPEN	0,INTDAT  	; Open for dump output.		*** MJC
66528		JRST	BADSEG		; Couldn't open?		*** MJC
66532		ENTER	0,HGHDAT+1	; Hookup to file.		*** MJC
66539		JRST	BADSEG		; Couldn't do it?		*** MJC
66546		CALLI	A,400022	; Find size of high segment.	*** MJC
66553		MOVNS	A		; Construct dump mode cmd wd.	*** MJC
66560		HRLM	A,HGHDAT+4	; I.e. -length to left half	*** MJC
66567		MOVEI	A,SHRST-1	;   and <start>-1 to rt half.	*** MJC
66574		HRRM	A,HGHDAT+4	;				*** MJC
66581		OUTPUT	0,HGHDAT+4	;				*** MJC
66588		CLOSE	0,2		; Leave no traces		*** MJC
66600		JRST	FALSE		;RETURN NIL
66610	BADSEG:	ERR1	[SIXBIT/ILLEGAL NAME FOR SEGMENT!/] ;		*** MJC
66620		JRST	FALSE	;					*** MJC
66700	
66800	REMOTE<WRTSTS: 1>
66900	PAGE
67000			SUBTTL REALLOC CODE     --- PAGE 19
67100	
67200	STRT:
67300	INALLC:	HRRZ	A,JOBREL	;SEE IF CORE WAS EXPANDED
67400		CAMN	A,JRELO#	;OR NOT
67500		JRST	OUTALC		;NO EXPANSION - DON'T REALLOCATE
67600		CAMG	A,JRELO#	;CHECK TO SEE IF IT GOT SMALLER!
67700		JRST	4,0		;YES - BITCH
67800		MOVEM	A,JRELO#	;SAVE NEW CORE BOUND
67900		HRLM	A,JOBSA
68000	IFN ALVINE,<
68100		MOVEI	F,ED+2		;INDICATE THAT ED WAS OVERWRITTEN
68200		HRRM	F,EDA		;SO ED AND GRINDEF WILL BE READ IN IF NEEDED>
68300	INAGN:	SETZM	NOALIN#		;SET UP TO ASK FOR ALLOCATION
68400		OUTSTR	[ASCIZ /
68500	ALLOC? (Y OR N) /]		;ASK USER IF HE WISHES TO SET UP
68600		INCHRW	C		;THE ALLOCATION INCREMENTS
68700		CAIGE	C,"O"
68800		SETOM	NOALIN#		;SET FLAG SO NO INPUT IS DONE LATER
68900	SETFWS:	MOVE	A,SFWS#		;SAVE OLD SIZE OF FWS
69000		MOVEM	A,OSFWS#
69100	
69200		SKIPN	NOALIN		;SKIP QUESTIONS IF AUTOMATIC
69300		OUTSTR	[ASCIZ /
69400	FULL WORD SP. = /]
69500		JSP	R,ALLNUM
69600		JUMPN	A,.+3
69700		SKIPE	INITFW#
69800		ADDI	A,440		;INITIAL ALLOCATION FOR FWS
69900	
70000		ADDM	A,SFWS#		;ADD EITHER USER INCREMENT OR 0 TO SFWS
70100	
70200		MOVE	A,FSO#		;SAVE OLD FS ORIGIN
70300		MOVEM	A,OFSO#		;FOR RELOCATION
70400	
70500	
70600		SKIPN	NOALIN		;SKIP IF USER DONE
70700		OUTSTR [ASCIZ /
70800	BIN. PROG. SP. = /]
70900		JSP	R,ALLNUM
71000		ADDM	A,SBPS#
71100		MOVEM	A,FSMOVE#	;THE INCREMENT TO SBPS IS THE AMOUNT BY
71200		ADDM	A,FSO#		;THE FREE SPACE IS MOVED - UPDATE ORIGIN
71300	
71400	
71500	
71600		SKIPN	NOALIN		;SKIPIF USER DONE
71700		OUTSTR [ASCIZ /
71800	REG. PDL. = /]
71900		JSP	R,ALLNUM
72000		JUMPN	A,.+3
72100		SKIPE	INITFW#		;CHECK IF INITIAL ALLOCATION
72200		ADDI	A,1000
72300		ADDM	A,SRPDL#
72400		MOVN	AR1,A		;SAVE IN CASE OF OVERFLOW
72500	
72600	
72700		SKIPN	NOALIN		;SKIP IF USER DONE
72800		OUTSTR [ASCIZ /
72900	SPEC. PDL. = /]
73000		JSP	R,ALLNUM
73100		JUMPN	A,.+3
73200		SKIPE	INITFW#	;CHECK FOR INITIAL ALLOCATION
73300		ADDI	A,1000
73400		ADDM	A,SSPDL#
73500		MOVN	AR2A,A		;SAVE IN CASE OF OVERFLOW
73600	IFN HASH,<
73700		SKIPN	INITFW
73800		SETOM	NOALIN
73900		SKIPN	NOALIN
74000		OUTSTR	[ASCIZ /
74100	HASH = /]
74200		JSP	R,ALLNUM
74300		CAIG	A,BCKETS
74400		JRST	OCR
74500		HRRM	A,INT1
74600		MOVNS	A
74700		HRRM	A,RH4
74800		SETOM	HASHFG>
74900	OCR:	OUTSTR	[ASCIZ /
75000	/]
75100		MOVE	A,JRELO#	;COMPUTE SIZE OF AVAILABLE CORE
75200		SUBI	A,FS		;SO THAT EXTRA CORE CAN BE DISTRIBUTED
75300	
75400		SUB	A,SBPS	;TAKE OFF CORE ALLOCATED FOR BPS
75500		SUB	A,SFS#		;TAKE OFF CORE IN PREVIOUS FS
75600		SUB	A,SBT#		;AND ASSOCIATED BIT TABLE
75700		SUB	A,SFWS		;TAKE OFF CORE NOW ALLOCATED TO FWS
75800		SUB	A,SRPDL		;TAKE OFF CORE NOW ALLOCATED TO RPDL
75900		SUB	A,SSPDL		;TAKE OFF CORE NOW ALLOCATED TO SPDL
76000	
76100		MOVE	F,SFWS		;ESTIMATE SIZE NEEDED FOR BTF
76200		IDIVI	F,44
76300		ADDI	F,1
76400		SUB	A,F		;AND TAKE IT OFF TOTAL
76500		MOVEM	F,SBTF#		;ALSO SAVE TO RESTORE LATER
76600		JUMPGE	A,ALOK		;MAKE SURE NO OVERFLOW
76700		OUTSTR	[ASCIZ /ALLOCATIONS ARE TOO LARGE
76800	/]				; IF SO THEN RETRY
76900		MOVE	A,OSFWS
77000		MOVEM	A,SFWS		;RESTORE SIZE OF FWS
77100		MOVN	A,FSMOVE
77200		ADDM	A,SBPS		;RESET SIZE OF BPS
77300		ADDM	A,FSO		;AND FS ORGIN
77400		ADDM	AR1,SRPDL	;RESET STACKS
77500		ADDM	AR2A,SSPDL
77600		JRST	INAGN
77700	
77800	ALOK:	MOVE	B,A		;NOW CAN ALLOCATE EXCESS CORE
77900	ACHLOC:	ASH	B,-4		;1/16 TO FWS
78000		ADDM	B,SFWS
78100		SUB	A,B		;TAKE IT OFF REMAINING CORE
78200		SKIPE	INITFW
78300		SETZ	B,
78400		ASH	B,-4		;1/64 TO PDLS
78500		ADDM	B,SSPDL
78600		SUB	A,B
78700		ADDM	B,SRPDL
78800		SUB	A,B		;AND TAKE IT OFF REMAINING CORE
78900	
79000		MOVE	T,SFWS		;CALCULATE ACTUAL SIZE OF BTF
79100		IDIVI	T,44
79200		ADDI	T,1
79300		ADD	A,SBTF		;REMOVE ESTIMATED LOSS FOR BTF
79400		MOVEM	T,SBTF
79500		SUB	A,T		;AND TAKE OFF ACTUAL LOSS TO BTF
79600	
79700		ADD	A,SFS		;ADD BACK ON SPACE FROM OLD FS
79800		ADD	A,SBT		;AND ASSOCIATED BT
79900					;GIVING NEW SPACE AVAILABLE FOR
80000					;FS AND BT
80100		MOVE	TT,A
80200		IDIVI	TT,41		;SBS = SFS/32.  = (SBS + SFS)/33.
80300	
80400		ADDI	TT,1
80500		MOVEM	TT,SBT
80600	
80700		SUB	A,TT		;TAKE OFF SBT FROM REMAINING CORE
80800		MOVEM	A,SFS		;GIVING AVAILABLE SFS
80900	
81000	
81100					;SET UP REGISTERS FOR GC ETC. SETUP
81200	
81300		MOVE	A,SFWS		;A ← SFWS
81400		MOVEI	B,FS
81500		ADD	B,SFS
81600		ADD	B,SBPS		;B ← NFWSO (ORIGIN OF NEW FULL WORD SPACE)
81700		MOVE	C,SRPDL		;C ← SRPDL
81800		MOVE	F,OSFWS		;F ← OLD SIZE OF FWS
81900	
82000	
82100	
82200	
82300		HRRM	B,GCP1		;GCP1 ← NFWSO
82400		MOVN	SP,B		;-NEW BOTTOM OF FWS
82500	
82600		HRRM	SP,GCMFWS
82700		HRLZM	A,C1GCS
82800		MOVNS	C1GCS		;-NEW LENGTH OF FWS
82900		HRRM	B,C1GCS		;HAVE FWS POINTER AND COUNT FOR SWEEP
83000	
83100		ADD	B,A		;NEW FIRST WORD OF BT (FS BIT TABLE)
83200	
83300	
83400		MOVE	SP,FSO		;SP ← NEW ORIGIN OF FS
83500	
83600		LSH	SP,-5
83700		SUBM	B,SP		;NUMBER USED TO FIND BIT TABLE WORD
83800		HRRM	SP,GCBTP1	;FROM FS WORD ADDRESS
83900		HRRM	SP,GCBTP2
84000	
84100		HRLM	B,C3GC		;BOTTOM OF BIT TABLES
84200		HRRM	B,GCP2
84300		HRRM	B,GCP		;(ALSO UPPER BOUND ON FWS AND FS)
84400	
84500		MOVNI	SP,-2(TT)	;-SIZE OF BT (TT = SBT)
84600		HRLM	SP,C3GCS	;IOWD FOR BIT TABLE SWEEP
84700		HRRM	B,C3GCS
84800		MOVE	SP,FSO
84900		ANDI	SP,37		;MASK OUT ALL BU LAST FIVE BITS
85000		HRRM	SP,GCBTL2	;MAGIC NUMBER TO POSITION
85100		SUBI	SP,40
85200		HRRM	SP,GCBTL1
85300	
85400		ADDI	B,1		;B ← B + 1
85500		HRRM	B,C3GC		;BOTTOM OF FS BIT TABLE + 1
85600		ADDI	B,-2(TT)	;GET BOTTOM OF BTF - 1, POINTER IS INCREMENTED
85700		HRRM	B,C2GCS		;BEFORE USE
85800	
85900		ADDI	B,1		;B ← B + 1
86000		HRRM	B,C2GC		;BOTTOM OF FWS BIT TABLE + 1
86100		ADDI	B,-1(T)		;SINCE T IS NOW SIZE OF BTF, NOT SBTF-1
86200	
86300		HRRM	B,GCP5			;TOP OF BIT TABLES
86400		ADDI	B,1		;BOTTOM OF REG PDL
86500	
86600		HRRZ	A,RHX2		;GET OBLIST POINTER
86700		ADD	A,FSMOVE	;INCREMENT TO
86800					;ACCOUNT FOR MOVE OF FS
86900		MOVEM	A,(B)
87000		HRRM	B,GCP3		;ROOM FOR ACS DURING GC
87100		ADDI	B,1		;B ← B + 1
87200		HRRM	B,GCSP1
87300		HRRM	B,GCP4		;ROOM FOR ACS
87400		ADDI	B,10		;B ← B + 10
87500		HRRM	B,GCP41		;TOP OF AC AREA
87600		ADDI	B,1		;B ← B + 1
87700		HRRM	B,C2		;SET UP RPDL POINTER
87800		MOVNI	A,-20(C)	;A ← - (C -20) = -(SRPDL - 20)
87900		HRLM	A,C2		;THIS IS THE ACTUAL SIZE OF RPDL
88000					;TAKING INTO ACCOUNT THE AC AREA
88100		
88200		HRRZ	A,JRELO#	;TOP OF CORE - FOR SPDL PTR
88300	
88400		MOVN	B,SSPDL
88500		ADD	A,B
88600		HRL	A,B
88700	
88800		MOVEM	A,SC2#	;SET UP SPDL POINTER (I HOPE)
88900		MOVN	A,A	;CREATE OFFSET FOR STACK POINTERS
89000		ADDI	A,INUM0
89100		HRRZM	A,SPNM#
89200		SETZM	INITFW	;TURN OFF INITIAL ALLOCATION FLAG
89300	
89400	
89500		
89600	
89700				;RELOCATE THE FULL WORD SPACE
89800				;GCP1 HOLDS POINTER TO ORIGIN OF NEW FWS
89900				;FWSO# HOLDS POINTER TO ORIGIN OF OLD FWS
90000				;AND F HOLDS SIZE OF OLD FWS (AMOUNT TO BE MOVED)
90100	
90200		MOVSI	B,F
90300		HRR	B,GCP1
90400		MOVE	C,FWSO#
90500		HRRZI	AR2A,-1(C)	;TAKE THE OPPORTUNITY TO GET ADDRESS
90600					;OF END OF OLD FS (USED LATER)
90700		HRLI	C,F
90800		MOVE	A,@C	;GET WORD FROM END OF OLD FWS
90900		MOVEM	A,@B	;AND MOVE TO END OF NEW FWS
91000		SOJGE	F,.-2	;F COUNTS DOWN WORDS IN OLDFWS
91100				;END OF FWS RELOCATION
91200	
91300		MOVE	FF,FSMOVE	;GET FAST ACCESS TO RELOCATE SIZE FOR FS
91400		HRRZ	F,AR2A
91500		ADD	F,FF		;AND FIND WHERE TO PUT WORDS FROM
91600					;END OF OLD FS IN NEW FS
91700	
91800	
91900	
92000		HRRZ	AR1,GCP1	;COMPUTE FWS RELOCATION CONSTANT
92100		SUB	AR1,FWSO
92200	
92300	
92400	
92500				;RELOCATE FS - ALSO RELOCATE ALL
92600				;POINTERS TO FS AND TO FWS
92700	
92800	REL1:	HLRZ	A,(AR2A)	;GET CAR POINTER OF OLD FS WORD
92900		JSP	R,REL4
93000		HRLM	A,(F)		;MOVE CAR TO NEW POSITION
93100		HRRZ	A,(AR2A)	;GET CDR PTR
93200		JSP	R,REL4		;CHECK FOR FS RELOCATE
93300		HRRM	A,(F)
93400		SUBI	F,1		;F ← F -1
93500		CAMLE	AR2A,OFSO	;CHECK TO SEE IF DONE
93600		SOJA	AR2A,REL1	;NO - GO LOOP
93700		HRRZ	A,GCMKL		;RELOCATE ARRAYS
93800		JSP	R,REL4
93900		HRRZ	D,A
94000		MOVEM	D,GCMKL
94100	REL5:	HLRZ	AR2A,(D)
94200		MOVE	AR2A,(AR2A)
94300	REL6:	HLRZ	A,(AR2A)
94400		JSP	R,REL4
94500		HRLM	A,(AR2A)
94600		HRRZ	A,(AR2A)
94700		JSP	R,REL4
94800		HRRM	A,(AR2A)
94900		AOBJN	AR2A,REL6
95000		HRRZ	D,(D)
95100		JUMPN	D,REL5
95200		SETZM	BIND3		;JUST IN CASE
95300		SKIPE	INITF		;DON'T FORGET THE INITFN
95400		ADDM	FF,INITF
95500		SKIPE	NOUUOF		;RELOCATE FLAGS
95600		ADDM	FF,NOUUOF
95700		SKIPE	BACTRF
95800		ADDM	FF,BACTRF
95900		SKIPE	GCGAGV
96000		ADDM	FF,GCGAGV
96100		SKIPE	RSTSW
96200		ADDM	FF,RSTSW
96300		JRST	RELFOO
96400	
96500	REL4:	CAMGE	A,EFWSO		;SEE IF BEYOND END OF FWS
96600		CAMGE	A,OFSO		;OK - SEE IF MAYBE IN FS
96700		JRST	(R)
96800		CAMGE	A,FWSO		;SEE IF IN FWS
96900		JRST	.+3
97000		ADD	A,AR1		;RELOCATE FWS POINTER
97100		JRST	(R)
97200		ADD	A,FF		;RELOCATE FS POINTER
97300		JRST	(R)
97400	
97500	
97600	
97700	
97800	
97900	RELFOO:	MOVE	S,SBPS		;S IS THE RELOCATOR FOR MOST MACRO
98000		MOVEM	S,ATMOV		;REFERENCES TO ATOMS AND FS
98100		MOVE	A,FSMOVE	;NOW IS THE TIME FOR ALL GOOD MEN TO
98200		ADDM	A,VBPEND(S)	;SET BPEND
98300		ADDM	A,XXX1		;AND SOMEOTHER CRAP
98400		ADDM	A,XXX2
98500		ADDM	A,XXX3
98600		ADDM	A,XXX4
98700		ADDM	A,XXX5
98800		MOVE	A,GCP1
98900		HRRZM	A,FWSO
99000		MOVE	A,C3GCS
99100		HRRZM	A,EFWSO#
99200	OUTALC:	CLEARB	F,DDTIFG
99300		JSP	R,IOBRST
99400		JRST	START
99500	
99600	
99700	
99800	
99900	
     

00100	
00200			;SUBROUTINE FOR NUMBER INPUT
00300	
00400	
00500	ALLNUM:	MOVEI	A,0
00600		SKIPE	NOALIN#
00700		JRST	(R)
00800		INCHRW	C
00900		CAIN	C,RUBOUT
01000		JRST	[OUTSTR [ASCIZ /XXX /]
01100			 JRST ALLNUM]
01200		CAIL	C,"0"
01300		CAILE	C,"9"
01400		JRST	BANGCK
01500		ASH	A,3
01600		ADDI	A,-"0"(C)
01700		JRST	ALLNUM+3
01800	
01900	BANGCK:	CAIE	C,LF
02000		JRST	(R)
02100		SETOM	NOALIN#
02200		JRST	(R)
02300	
02400			;RETURNS 0 IF NOALIN # 0
02500			;SETS NOALIN # 0 IF IT GETS A LINE FEED INPUT
02600	
02700	
02800	
02900	PAGE
03000	
03100	
03200	
03300	
03400	IFN HASH,<
03500	REHASH:
03600		MOVEI A,BFWS(S)
03700		PUSH P,A
03800		HRRM A,RHX2
03900		HRRM A,RHX5
04000		MOVS B,RH4#
04100		ADD B,S	;$$PUT IN ATOM MOVE OFFSET IN B, SINCE CAN'T
04200				;$$DOUBLE INDEX - THIS REMOVES THE FOO PROBLEM
04300				;$$IN THE NEXT THREE FOO'S
04400	
04500		HRRZI A,BFWS+1(B)
04600		MOVEM A,BFWS(B)
04700		AOBJN B,.-2
04800		SETZM BFWS(B)
04900		MOVSI AR2A,-BCKETS
05000		HRR AR2A,S	;$$PUT IN ATOM MOVE OFFSET IN AR2A TO AVOID
05100				;$$DOUBLE INDEXING WITH S IN REMOVING FOO
05200				;$$PROBLEM
05300	RH1:
05400		HLRZ C,OBTBL(AR2A)
05500	RH3:	JUMPE C,RH2
05600		HLRZ A,(C)
05700		PUSH P,C
05800		PUSH P,AR2A
05900		PUSHJ P,INTERN
06000		POP P,AR2A
06100		POP P,C
06200		HRRZ C,(C)
06300		JRST RH3
06400	RH2:	AOBJN AR2A,RH1
06500		SETZM HASHFG
06600		POP P,A
06700		HRRM A,@GCP3
06800		MOVEM A,OBLIST(S)
06900		JRST START>
07000	
07100		PAGE
07200		SUBTTL NEW FUNCTIONS TO MAKE USE OF MODIFIED SPECIAL PDL FOR ERRORS
07300	
07400	;$$ROUTINE TO GET POINTER TO SPDL AND MAKE IT INTO AN INUM
07500	SPDLPT:	HRRZ	A,SP	;$$CREATE A POINTER TO THE CURRENT TOP OF STACK
07600		ADD	A,SPNM
07700		POPJ	P,		;$$
07800	
07900	
08000	;$$ROUTINE TO GET LEFT HAND SIDE OF SPDL ITEM INDICATED BY AN INUM FROM SPDLPT
08100	SPDLFT:	SUB	A,SPNM	;$$CONVERT TO ADDRESS
08200		HLRE	A,(A)	;$$GET LEFT HAND ITEM
08300		JUMPL	A,TRUE		;$$IF IT IS NEGATIVE IT CAME FROM A STACK
08400					;$$POINTER AND WE RETURN T INSTEAD
08500		HRRZI	A,(A)		;$$CLEAR OUT LEFT HAND OF AC
08600		POPJ	P,		;$$RETURN - RETURNS NIL FOR LHS = 0
08700	
08800	;$$ROUTINE TO GIVE RIGHT HAND SIDE OF SPDL ENTRY SPECIFIED BY AN INUM FROM SPDLPT
08900	SPDLRT:	SUB	A,SPNM		;$$CONVERT TO AN ADDRESS
09000		HRRZ	A,(A)	;$$ALL RHS ITEMS ARE LEGAL, NO NEED FOR CHECK
09100		POPJ	P,		;$$
09200	
09300	;$$ROUTINE TO GET POINTER TO NEXT EVAL BLIP ON SPDL
09400	NEXTEV:	SUB	A,SPNM	;$$GET POINTER INSTEAD OF INUM
09500		HRRZ	T,SC2	;$$GET POINTER TO BOTTOM OF SPDL
09600	
09700	SPDNLP:	CAMG	A,T	;$$CHECK IF HIT THE BOTTOM OF SPDL
09800		JRST	FALSE	;$$RETURN NIL IF NO MORE INTERESTING WORDS
09900		HLL	A,(A)	;$$TEST FOR WORD WITH 0 LHS
10000		TLZE	A,-1	;$$
10100		SOJA	A,SPDNLP	;$$NOT AN INTERESTING WORD, LOOK AGAIN
10200		ADD	A,SPNM	;$$FOUND AN INTERESTING WORD, CHANGE POINTER TO INUM
10300		POPJ	P,	;$$
10400	
10500	
10600	;$$ROUTINE TO EVALUATE A VARIABLE IN AN EARLIER CONTEXT
10700	;$$	MORE EFFICIENT THAN EVAL WITH ALIST
10800	EVALV:	MOVE	C,A		;$$ MOVE AROUND FOR ATOM CHECK
10900		PUSHJ	P,ATOM	;$$
11000		EXCH	A,C		;$$
11100		SUB	B,SPNM		;$$
11200	EVALV1:	CAIN	B,(SP)		;$$CHECK FOR END OF SPDL
11300		JRST	GETV		;$$VARIABLE NOT REBOUND - GET CURRENT VALUE
11400		SKIPGE	,(B)		;$$CHECK TO AVOID SPDL POINTERS ON  STACK
11500		AOJA	B,EVALV1	;$$
11600		HLRZ	T,(B)		;$$T←CAR(B)
11700		SKIPE	C		;$$
11800		HLRZ	T,(T)		;$$GET CAR OF SPECIAL CELL - ATOM POINTER
11900		CAIE	T,(A)		;$$COMPARE WITH ATOM TO BE EVALUATED
12000		AOJA	B,EVALV1	;$$NOT IT, LOOK SOME MORE
12100		HRRZ	A,(B)		;$$GET VALUE FROM SPDL
12200		POPJ	P,		;$$
12300	
12400	GETV:	JUMPE	C,GETV1
12500		MOVEI	B,VALUE(S)		;$$ATOM NOT REBOUND, VALUE THEN IS 
12600		PUSHJ	P,GET		;$$
12700		JUMPE	A,UNBOND	;$$NOT BOUND AT ALL, GIVE UNBVAR MESSAGE
12800	GETV1:	HRRZ	A,(A)		;$$GET CDR OF SPECIAL CELL
12900		POPJ	P,		;$$
13000	
13100	UNBOND:	HRRZI	A,UNBOUND(S)	;$$RETURN ATOM UNBOUND
13200		POPJ	P,		;$$
13300	
13400	;$$ROUTINE TO CLEAR SPECIAL PDL TO POSITION SPECIFIED BY INUM
13500	CLRSPD:	MOVEI	B,-2-INUM0(A)	;$$ -2 TO GET OVER EVAL BLIP
13600		HLRZ	TT,SC2#	;$$GET REAL SPD POINTER WITH A LHS
13700		ADD	TT,B	;$$FIND OUT HOW MANY WORDS ARE USED
13800		ADD	B,SC2	;$$
13900		HRL	B,TT	;$$SET UP SPD POINTER
14000		JRST	UBD		;$$UBD DOES ALL THE WORK
14100	
14200	;$$ROUTINE TO RETURN FROM SPECIAL PDL CONTEXT, SPECIFIED BY AN
14300	;$$EVAL BLIP, WITH A GIVEN VALUE
14400	OUTVAL:	PUSHJ	P,NEXTEV	;$$FORCE TO AN EVAL BLIP
14500		JUMPE	A,FALSE		;$$ NO EVAL BLIP, RETURN NIL
14600		HRLZI	C,(POPJ P,)	;$$ SET TYPE OF RETURN
14700		JRST	SPRE1		;$$ FINISH UP IN SPREDO
14800	
14900	
15000	;$$ROUTINE TO RE-EVALUATE EXPRESSION FROM AN EVAL BLIP AND GO ON FROM
15100	;$$ THAT CONTEXT (NOT A USER CALLABLE FUNCTION)
15200	REVAL1:	HRRZ	P,1(SP)		;$$ RPDL POINTER IS UP ONE
15300		HRRZ	T,C2#		;$$
15400		HLRZ	TT,C2#		;$$
15500		ADD	TT,P		;$$
15600		SUB	TT,T		;$$
15700		HRL	P,TT		;$$
15800	DOSET:	MOVE D,ERRTN	;$$ POP ERRSETS, LOAD CURRENT ERRSET
15900		SKIPE D		;$$DONE IF EMPTY
16000		CAMG D,P		;$$ COMPARE TO CURRENT RPDL
16100		XCT C		;$$ DONE, DO A STRANGE EXIT
16200		SUB D,[XWD 1,1]	;$$ GO DOWN A WORD
16300		POP D,ERRSW	;$$
16400		POP D,ERRTN	;$$
16500		SUB D,[XWD 2,2]	;$$ SKIP PROG JUNK
16600		JRST DOSET	;$$ TRY AGAIN
16700	
16800	
16900	
17000	;$$ROUTINE TO CLEAR SPD TO A GIVEN POINT AND REDO FROM THERE
17100	;$$ A CONTAINS AN SPD INUM POINTER, FORCE IT TO BE EVAL BLIP POINTER
17200	
17300	SPREDO:	PUSHJ	P,NEXTEV	;$$FORCE TO EVAL BLIP POINTER
17400		JUMPE	A,CPOPJ		;$$RETURN NIL IF NO EVAL BLIP
17500		MOVE	B,A	;$$GET THE EXPRESSION
17600		SUB	B,SPNM
17700		HRRZ	B,(B)
17800		MOVE	C,[JRST EVAL]	;$$SET RETURN
17900	SPRE1:	PUSH	P,B		;$$SAVE SPDL POINTER
18000		PUSHJ	P,CLRSPD	;$$CLEAR OUT SPD - INCLUDES RESTORING PROGS
18100		POP	P,A		;$$
18200		JRST	REVAL1
18300	
18400	;$$ SPREVAL - SIMILAR TO OUTVAL BUT EVALUATES THE GIVEN VALUE
18500	;$$AS OF THE SPECIFIED CONTEXT, EQUIVALENT TO:
18600	;$$ (PROG2 (RPLACD (NUMVAL (SETQ A (NEXTEV A))) B) (SPREDO B))
18700	;
18800	SPREVAL:PUSHJ P,NEXTEV		;$$FORCE TO AN EVAL-BLIP
18900		JUMPE	A,CPOPJ		;$$RETURN NIL IF NO EVAL-BLIP
19000		JRST	SPRE1-1		;$$LET SPREDO FINISH UP
19100	
19200	
19300	;$$COMPUTES A LISP POINTER TO A STACK ENTRY
19400	STKPTR:	SUB	A,SPNM
19500		POPJ	P,
19600	
19700	LALL
19800	PAGE
19900		SUBTTL LOW SETMENT INCLUDING REMOTE CODE
20000		RELOC	0
20100		HERE
20200	VAR
20300	XALL
20400		PAGE
20500		SUBTTL LISP ATOMS AND OBLIST	--- PAGE 20
20600	FS:
20700	
20800	DEFINE MAKBUC (A,%B)
20900	<DEFINE OBT'A <%B=.>
21000	XWD %B,IFN <<BCKETS-1>-A>,<.+1>
21100	IF1 <%B=0>>
21200	
21300	DEFINE ADDOB (A,C,%B)
21400	<OBT'A
21500	DEFINE OBT'A<%B=.>
21600	IF1 <%B=0>
21700	XWD C,%B>
21800	
21900	DEFINE PUTOB (A,B)
22000	<ZZ==<ASCII +A+>←<-1>
22100	ZZ==-ZZ/BCKETS*BCKETS+ZZ
22200		ADDOB \ZZ,B>
22300	
22400	DEFINE PSTRCT (A)
22500	<ZZ==[ASCII +A+]
22600	LENGTH(ZY,<A>)
22700	ZY==<ZY-1>/5
22800	Q1(ZY,ZZ)
22900	>
23000	
23100	DEFINE Q1 (N,Z)<
23200	IFN N,<XWD Z,[Q1(N-1,Z+1)]>
23300	IFE N,<XWD Z,0>>
23400	DEFINE MKAT (A,B,C,D)
23500	<XLIST
23600	IRP A< PUTOB A,.+1
23700	D	XWD -1,.+1
23800		XWD B,.+1
23900		XWD C'A,.+1
24000		XWD PNAME,.+1
24100		XWD [PSTRCT(A)],0>
24200	LIST>
24300	
24400	DEFINE MKAT1 (A,B,C,D)
24500	<XLIST
24600	IRP C <PUTOB C,.+1
24700		XWD -1,.+1
24800		XWD B,.+1
24900		XWD D'A,.+1
25000		XWD PNAME,.+1
25100		XWD [PSTRCT(C)],0>
25200	LIST>
25300	DEFINE LENGTH (A,B)
25400	<A==0
25500	IRPC B,<A==A+1>>
25600	DEFINE ML1 (A)<IRP A,<
25700	V'A:	XWD	-1,.+1
25800		XWD	FIXNUM,[A]
25900		MKAT A,SYM,V
26000	>>
26100	
26200	DEFINE MKSY1 (A,B,%C)<
26300	XLIST
26400	%C:	XWD	-1,.+1
26500		XWD	FIXNUM,[A]
26600		PUTOB B,.+1
26700		XWD	-1,.+1
26800		XWD	SYM,.+1
26900		XWD	%C,.+1
27000		XWD	PNAME,.+1
27100		XWD	[PSTRCT(B)],0
27200	LIST>
27300	
27400	DEFINE ML (A)<
27500	XLIST
27600	IRP A,<PUTOB A,.+1
27700	A:	XWD -1,.+1
27800		XWD PNAME,.+1
27900		XWD [PSTRCT(A)],0>
28000	LIST>
28100	DEFINE MK (A)<
28200	XLIST
28300	IRP A,<PUTOB A,.+1
28400		XWD -1,.+1
28500		XWD PNAME,.+1
28600		XWD [PSTRCT(A)],0>
28700	LIST>
28800	
28900	OBTBL:
29000	OBLIST:	ZZ==0
29100	XLIST
29200	REPEAT BCKETS,<MAKBUC \ZZ
29300	ZZ==ZZ+1>
29400	LIST
29500	
29600	PAGE
29700	MKAT<RPLACA,RPLACD,MINUS,TERPRI,READ,CAR,CDR,CAAR>,SUBR
29800	MKAT<CADR,CDAR,CDDR,CAAAR,CAADR,CADAR,CADDR,CDAAR,CDADR,CDDAR,CDDDR>,SUBR
29900	MKAT<CAAAAR,CAAADR,CAADAR,CAADDR,CADAAR,CADADR,CADDAR,CADDDR,CDAAAR>,SUBR
30000	MKAT<CDAADR,CDADAR,CDADDR,CDDAAR,CDDADR,CDDDAR,CDDDDR,MAKNUM,CONS>,SUBR
30100	MKAT<STRINGP,ATOM,PATOM,EQ,PRIN1,PRINT,RETURN,EXPLODE,SASSOC,ASSOC>,SUBR
30200	MKAT<GCGAG,CHRCT,LINELENGTH,NUMBERP,EQUAL,SUBST,GET,INTERN,MEMBER>,SUBR
30300	MKAT<LOAD,MAKNAM,READCH,NOT,NULL,GENSYM,ZEROP,DIVIDE,GCD>,SUBR
30400	MKAT<TIME,FIX,SET,PROG2,LENGTH,READLIST,LAST,ADD1,SUB1>,SUBR
30500	MKAT<GCTIME,REVERSE,SPEAK,GC,GETL,BAKGAG,MEMQ>,SUBR
30600	MKAT<PUTPROP,PRINC,FLATSIZE,ERR,EXAMINE,DEPOSIT,LSH>,SUBR
30700	MKAT<NCONS,XCONS,REMPROP,ARG,SETARG,NOUUO,MINUSP>,SUBR
30800	MKAT<OUTC,INC,DDTIN,INITFN,EXCISE,REMAINDER,ABS>,SUBR
30900	MKAT<PROG1,SPRINT,LITATOM,NTHCHAR>,SUBR
31000	IFN STPGAP,<MAKAT<PGLINE>,SUBR>
31100	
31200	MKAT EXPLODEC,SUBR,%
31300	MKAT TAB,SUBR,.
31400	MKAT TYO,SUBR,I
31500		MKAT TYI,SUBR,I
31600	CEVAL=.+1
31700	MKAT1 EVAL,SUBR,*EVAL
31800	
31900	;$$ REDEF. FOR NEW MAP FUNCTIONS
32000	MKAT<MAPCAN,MAPCON,MAPLIST,MAPCAR,MAP,MAPC>,LSUBR
32100	;$$ GIVE MAPCAN THE DOUBLE NAME MAPCONC
32200	MKAT1 MAPCAN,LSUBR,MAPCONC
32300	
32400	PROGAT:	MKAT<PROG>,FSUBR
32500	
32600	MKAT <PROGN,LIST,COND,SETQ,INPUT,OUTPUT,SETSYS>,FSUBR
32700	IFN ALVINE,<MKAT<GRINDEF>,FSUBR
32800		    MKAT<ED>,SUBR>
32900	IFE ALVINE,<MK<GRINDEF>>
33000	MKAT<ERRSET,REMOB,OR,GO,ARRAY,STORE>,FSUBR
33100	MKAT<AND,DEFPROP,CSYM,EXARRAY>,FSUBR
33200	MKAT1 QUOTE,FSUBR,FUNCTION
33300	MKAT1 %CLRBFI,SUBR,CLRBFI
33400	MKAT1 .ERROR,SUBR,ERROR
33500	MKAT1 LINRD,SUBR,LINEREAD
33600	MKAT1 UNBOND,SUBR,UNBOUND
33700	MKAT1 ECHO,SUBR,TTYECHO
33800	MKAT1 FUNCT,FSUBR,*FUNCTION
33900	MKAT <APPEND,NCONC,BOOLE,APPLY>,LSUBR
34000	
34100	MKAT EVAL,LSUBR,O
34200	MKAT ASCII,SUBR,A
34300	MKAT QUOTE,FSUBR,,CQUOTE:
34400	MKAT INUM0,SYM
34500	
34600		PUTOB T,.+1
34700	TRUTH:	XWD -1,.+1
34800		XWD VALUE,.+1
34900		XWD VTRUTH,.+1
35000		XWD PNAME,.+1
35100		XWD [PSTRCT(T)],0
35200	VTRUTH:	TRUTH
35300	
35400		PUTOB NIL,0
35500	CNIL2:	XWD VALUE,.+1
35600		XWD VNIL,.+1
35700		XWD PNAME,.+1
35800		XWD [PSTRCT(NIL)],0
35900	VNIL:	NIL
36000	MKSY1 %LCALL,*LCALL
36100	MKSY1 %AMAKE,*AMAKE
36200	MKSY1 %UDT,*UDT
36300	MKSY1 .MAPC,*MAPC
36400	MKSY1 .MAP,*MAP
36500	MKAT1 %NOPOINT,VALUE,*NOPOINT
36600	%NOPOINT:	NIL
36700	
36800	
36900	UNBOUND:	XWD -1,.+1
37000		XWD PNAME,.+1
37100		XWD [PSTRCT(UNBOUND)],0
37200	PAGE
37300	MKAT1 EXPN1,SUBR,*EXPAND1
37400	MKAT1 EXPAND,SUBR,*EXPAND
37500	MKAT1 PLUS,SUBR,*PLUS,.
37600	MKAT1 DIF,SUBR,*DIF,.
37700	MKAT1 QUO,SUBR,*QUO,.
37800	MKAT1 TIMES,SUBR,*TIMES,.
37900	MKAT1 APPEND,SUBR,*APPEND,.
38000	MKAT1 RSET,SUBR,*RSET,.
38100	MKAT1 GREAT,SUBR,*GREAT,.
38200	MKAT1 LESS,SUBR,*LESS,.
38300	MKAT1 PUTSYM,SUBR,*PUTSYM
38400	MKAT1 GETSYM,SUBR,*GETSYM
38500	
38600	ML1 <SPECBIND,SPECSTR,FIX1A,NSTR>
38700	
38800		PUTOB NUMVAL,.+1
38900		XWD -1,.+1
39000		XWD SUBR,.+1
39100		XWD NUMVAL,.+1
39200		XWD SYM,.+3
39300		XWD FIXNUM,[NUMVAL]
39400		XWD -1,.-1
39500		XWD .-1,.+1
39600		XWD PNAME,.+1
39700		XWD [PSTRCT(NUMVAL)],0
39800	
39900	MKAT <OBLIST,BASE,IBASE,BPEND,BPORG>,VALUE,V
40000	
40100	;$$ATOMS FOR DEFINITIONS OF FUNCTIONS FOR NEW SPDL PACKAGE
40200	
40300		ML ERRORX
40400		MKAT1 INTPRP,SUBR,INITPROMPT
40500		MKAT1 LSPRET,FSUBR,**TOP**
40600		MKAT<PROMPT,READP,UNTYI,STKPTR,SPREDO,SPREVAL>,SUBR
40700		MKAT<MEMB,NEXTEV>,SUBR
40800		MKAT<SPDLFT,SPDLRT,SPDLPT>,SUBR
40900		MKAT<EVALV,OUTVAL>,SUBR
41000	
41100	;$$ MORE EXTENSIONS INCLUDING READ MACROS
41200		ML READMACRO
41300		MKAT1 %FLATSIZEC,SUBR,FLATSIZEC
41400		MKAT <NEQ,CONSP,CHRVAL,SETCHR,MODCHR,COPY,LEXORDER>,SUBR
41500		MKAT <FREE,FREELIST,SYSCLR,HGHCOR,HGHORG,HGHEND>,SUBR
41600		MKAT1 FALSE,FSUBR,SPECIAL
41700		MKAT1 FALSE,FSUBR,NOCALL
41800		MKAT1 FALSE,FSUBR,DECLARE
41900		MKAT1 FALSE,FSUBR,NILL
42000		MKAT1 APPLY.,SUBR,APPLY#
42100		MKAT1 .MAX,SUBR,*MAX
42200		MKAT1 .MIN,SUBR,*MIN
42300		MKAT1 MEMBR.,SUBR,MEMBER#
42400		MKAT1 MEMB,SUBR,MEMQ#
42500		MKAT1 AND.,FSUBR,AND#
42600		MKAT1 OR.,FSUBR,OR#
42700	
42800	;$$ THE BREAK VARIABLES WHICH TELL ABOUT DEPTH IN THE BREAK PACKAGE
42900		MKAT1 BIOCHN,VALUE,#%IOCHANS%#
43000		MKAT1 BPMPT,VALUE,#%PROMPTS%#
43100		MKAT1 BINDNT,VALUE,#%INDENT
43200	BIOCHN:	NIL
43300	BPMPT:	NIL
43400	BINDNT:	INUM0
43500	
43600	VOBLIST:	OBLIST
43700	VBASE:	8+INUM0
43800	VIBASE:	8+INUM0
43900	
44000	ML <PNAME,FIXNUM,FLONUM,VALUE,LAMBDA,SUBR,FSUBR,EXPR,FEXPR,SYM,∨
44100	$EOF$,LABEL,FUNARG,LSUBR,MACRO>
44200	
44300		PUTOB ?,.+1
44400	QST:	XWD -1,.+1
44500		XWD PNAME,.+1
44600		XWD [PSTRCT(?)],0
44700	
44800	VBPORG:	INUM0
44900	VBPEND:	INUM0
45000	
45100	;MKAT ACHLOC,SYM
45200	;DONT KNOW WHATS UP HERE, IF NEEDED CHECK ACHLOC
45300	
45400	PAGE
45500	;
45600	;	ALL THE ATOMS IN THE WHOLE SYSTEM
45700	MK<A,ADD,AFTER,ALIAS,ARGPRINT,ASSOC#,ATM,B,BEFORE,BELOW,BEND1,BF,BI,BIND>
45800	MK<BK,BKE,BKEV,BKEVAL,BKF,BKFNLIST,BKFV,BKPOS,BKPROG,BKSETQ,BKV>
45900	MK<BLOCK,BLOCKED,BO,BORG1,BREAK>
46000	MK<BREAKMACROS,BREAK0,BREAK1,BREAK1ERX,BRKAPPLY>
46100	MK<BRKCOMS,BRKEXP,BRKFN,BRKTYPE,BRKWHEN,BROKEN,BROKENFNS>
46200	MK<BY,C,CAIE,CAIN,CALL,CALLF,CALLF@,CAME,CAMN,CAN'T,CHANGE>
46300	MK<CHNGDFLG,CLEARB,CLEARM,COM,COM0>
46400	MK<COMS,COMSQ,COPYFLG,CPTR,D,DE,DEFSYM,DELETE,DF>
46500	MK<DIFFERENCE,DIFFERENT EXPRESSION,DM,DREVERSE,DRM,DSKIN>
46600	MK<DSKOUT,DSM,DSUBST,E,EDIT,EDIT-SAVE>
46700	MK<EDIT4E,EDIT4F,EDIT4F1,EDIT:,EDITBF,EDIT1,EDITCOMSL>
46800	MK<EDITE,EDITF,EDITFNS,EDITFPAT>
46900	MK<EDITL,EDITL0,EDITL1,EDITMACROS,EDITMBD,EDITMV>
47000	MK<EDITOPS,EDITQF,EDITRACEFN,EDITXTR,EMBED,ENTER ,ERXACTION>
47100	MK<EX,EXCH,EXTRACT,F,F=,FF,FILES-LOADED,FINDFLAG,FNDBRKPT,FOR,FOUND>
47200	MK<FROM,FROM?=,FS,FUNTYPE,G,GETSYM,GREATERP,GRINL,GVAL>
47300	MK<GWD,HERE,HLLZS@,HLRZ,HLRZ@,HRLM@,HRRM,HRRM@,HRRZ,HRRZ@,HRRZS@>
47400	MK<I,IF,IN,INSERT,INSIDE,JCALL,JCALLF,JCALLF@,JRST,JSP>
47500	MK<JUMPE,JUMPN,KLIST,L,L0,L11,L12,LAP,LAPEVAL,LAPLST,LASTAIL>
47600	MK<LASTPOS,LASTWORD,LASTP1,LASTP2,LASTVALUE,LC,LCFLG,LCL,LDIFF,LESSP>
47700	MK<LEXPR,LI,LO,LP,LPQ,LPTLENGTH,LSUBST>
47800	MK<M,MARK,MARKLST,MAX,MAXLEVEL,MAXLEVEL EXCEEDED>
47900	MK<MAXLOOP,MAXLOOP EXCEEDED,MBD,MIN,MOVE,MOVEI,MOVEM>
48000	MK<MOVNI,MV,N,N?,NAMESCHANGED,NEX,NOT BLOCKED,NOT EDITABLE>
48100	MK<NOTHING SAVED,NTH,NX,OCCURRENCES,OK,OLDPROMPT,OPS,ORF,ORR>
48200	MK<P,PLEV,PLUS,POP,POPJ,PP,PREVEV,PRINLEV,PRINTLEV>
48300	MK<PUSH,PUSHJ,PUTSYM,QLIST,QUOTIENT,R,READBUF>
48400	MK<REDEFINED,REMOVE,REPACK,REPLACE,RETFROM,RI,RO>
48500	MK<S,SAVE,SECOND,SELECTQ,SN,SOJE,SOJN>
48600	MK<START,STKCOUNT,STKNAME,STKNTH>
48700	MK<STKSRCH,STOP,SUB,SUBPAIR,SURROUND,SW>
48800	MK<TAILP,TCONC,TDZA,TEST,THIRD,THROUGH,THRU,TIMES,TO>
48900	MK<TOFLG,TOPFLG,TRACE,TRACEDFNS,TTY:,TYPE,UNBLOCK,UNBREAK>
49000	MK<UNBREAK0,UNBREAKABLEFNS,UNDEF,UNDO>
49100	MK<UNDOLST,UNDOLST1,UNDONE,UNFIND,UNTRACE,UP>
49200	MK<UPFINDFLG,USE,USERMACROS,WHEN,WITH,X,XTR,Y,ZZ>
49300	MK<@,<\>,<\#\ >,<\P>,↑,↑↑,←,←←, ,   ,  ?, . ,< . UNBOUND)>>
49400	MK<- LOCATION UNCERTAIN, = ,!  ,!0,!NX,!UNDO,!VALUE,##>
49500	MK<#1,#2,#3,$%DOTFLG,%%BKPOS,%%CMDL,%%V>
49600	MK<%DEFINE,%DEREAD,%DEVP,%ERDEPTH,%LOOKDPTH,%PREVFN%>
49700	MK<%PRINFN,%READIN,&,& ,<(>,<(DEFPROP >,<)>,*,*ANY*,*RSETERX,-->
49800	MK<-IN-,::,:::,/BREAK1,:,=,==,?=,??>
49900	MK<... , ...],BINARY PROGRAM SPACE EXCEEDED>
50000	MK<NOT A TAIL - LDIFF,NO EVAL BLIP - RETFROM>
50100	MK<BAD ARGUMENT - LCONC,BAD ARGUMENT - TCONC>
50200	MK<DSK:,INIT,LSP,NOT IN SYMBOL TABLE,& UNHAPPY>
50300	MK<ARGUMENTS NOT FOUND,NOT BREAKABLE FUNCTION,ARGUMENT LIST?>
50400	MK<AROUND,BREAKIN,EDBRK,BROKEN-IN,EDVAL,DREMOVE,LCONC,SUBLIS>
50500	MK<EDITDSUBST,MAKEFN,FNDEF,LXPD,WHERE,MESS>
50600	MK<SHOULD BE LIST,SHOULD BE LIST OF ATOMIC ARGUMENTS>
50700	MK<FSUBR -- TAKES ONLY ONE ARGUMENT,UNBREAKABLE UNLESS 'IN' SOMETHING>
50800	MK<EDITV,GRINPROPS,=EDITV,EDITP,ARGS,EDITFINDP>
50900	
51000	;ATOMS OF GENERATED FUNCTIONS
51100	MK<SUBFUN1ARGPRINT,SUBFUN1BREAKIN0,SUBFUN1EDITCONT,SUBFUN1EDITL1,SUBFUN1EDOR>
51200	MK<SUBFUN1EDVAL,SUBFUN1ERRCOM>
51300	BFWS:
51400	EFWS:	0
51500	RELOC
51600	XLIST
51700	LIT
51800	LIST
51900	BHORG:	0
52000	RELOC
52100		PAGE
52200			SUBTTL LISP STORAGE ALLOCATOR (ONCE ONLY) --- PAGE 21
52300	
52400	
52500	ALLOC:	CLEARM	0,SBPS		;SET UP INITIAL ALLOCATIONS FOR SPACE
52600		HRRZI	A,BFWS-FS	;THIS IS THE SIZE OF THE ORIGINAL FS
52700		HRRZM	A,SFS
52800		HRRZI	A,EFWS-BFWS	;THIS ALLOWS ONLY THE INITIAL
52900		HRRZM	A,SFWS		;FWS
53000		HRRZI	A,0		;THE INITIAL ALLOCATION FOR SPDL
53100		HRRZM	A,SSPDL
53200		HRRZM	A,SRPDL		;AND FOR RPDL IS SET UP IN INALLC
53300		HRRZI	A,FS
53400		HRRZM	A,FSO		;THIS SETS UP INITIAL FS POINTER
53500		HRRZI	A,BFWS		;THIS SETS UP INITIAL FWS ORIGIN POINTER
53600		HRRZM	A,FWSO#
53700	
53800		HRRZI	A,EFWS
53900		HRRZM	A,EFWSO#
54000	
54100	
54200		MOVEI	A,FS
54300		ADDM	A,VBPORG	;SET UP VARIABLE FOR BPS ORIGIN
54400		SOS	A
54500		ADDM	A,VBPEND
54600	
54700		MOVE	A,JOBREL
54800		HRLM	A,JOBSA
54900		CALLI 	RESET
55000		MOVEI	A,DDT
55100		CALLI	A,2	;SET UP DDT REENTRY POINT FOR AUTOMATIC CONTROL H
55200		MOVEI	A,LISPGO
55300		HRRM	A,JOBSA
55400	
55500		SETOM	INITFW#		;FLAG FOR STANDARD INITIALIZATION OF
55600		SETZM	JRELO#		;OF SIZES, AND TO INDICATE CORE WAS EXPANDED
55700	
55800		JRST	INALLC
55900	
56000	
56100	DEFINE MKENT (A)<
56200	INTERNAL A>
56300	
56400	MKENT <EVBIG,NUMBP2,OPOV,NUMV2,NUMV3,NUMV4,OPR,FLOOV,FIX2>
56500	MKENT <NUM1,NUM3,BPR,FWCONS,FALSE,TRUE,FW0CNS,NCONS>
56600	MKENT <READ,READP1,MAKNUM,PRIN1,PRINT,EXPLODE,SASSOC,EQUAL,SUBST>
56700	MKENT <CHCT,LINL,OLDCH,FLATSIZE,TYI,RATOM,CHRCT,TYOD>
56800	MKENT <GET,INTERN,REMOB,MAKNAM,GENSYM,FIX,LENGTH,READLIST,PATOM>
56900	MKENT <LAST,INC,OUTC,FIX1A,NUMVAL,REVERSE,MAPLIST,GC,GETL,PUTPROP>
57000	MKENT <ERR,MAPCAR,REMPROP,LIST,SETQ,ERRSET,REMOB,ARRAY,APPEND>
57100	MKENT <SPECBIND,SPECSTR,XCONS,ATOM,READCH,SET,NCONC,PRINC>
57200	MKENT <CONS,ACONS,CTY,FP7A1,TERPRI,LSPRET>
57300	MKENT <TYO,ITYO,IGSTRT,NOINFG,CHRTAB,EVAL,OEVAL,.APPEND,INPUT,OUTPUT>
57400	IFN ALVINE,<MKENT<PSAV1,BKTRC>>
57500	
57600	;$$ FOR ALAN'S DIRECT ACCESS INPUT
57700	MKENT <ININBF,TYI2,TYIA,INCH>
57800	
57900	;$$ FOR ALVINE
58000	MKENT <PROMPT,INUM0,MEMQ,UNBOUND>
58100	
58200	PAGE
58300		END ALLOC
58400